From: charlet Date: Mon, 5 Sep 2005 07:47:56 +0000 (+0000) Subject: 2005-09-01 Hristian Kirtchev X-Git-Tag: upstream/4.9.2~58859 X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=d62940bfa0c906f830712fc4334d3a5d5d45c728;p=platform%2Fupstream%2Flinaro-gcc.git 2005-09-01 Hristian Kirtchev Javier Miranda Gary Dismukes Ed Schonberg * a-tags.adb (IW_Membership): Give support to "Iface_CW_Typ in T'Class". For this purpose the functionality of this subprogram has been extended to look for the tag in the ancestors tag table. Update the structure of the GNAT Dispatch Table to reflect the additional two tables used in dispatching selects. Introduce appropriate array types and record components in Type_Specific_Data to reflect the two tables. (Get_Entry_Index, Set_Entry_Index): Retrieve and set the entry index in the TSD of a tag, indexed by position. (Get_Prim_Op_Kind, Set_Prim_Op_Kind): Retrieve and set the primitive operation kind in the TSD of a tag, indexed by position. * a-tags.ads: Introduce an enumeration type to capture different primitive operation kinds. Define a constant reflecting the number of predefined primitive operations. (Get_Entry_Index, Set_Entry_Index): Set and retrieve the entry index of an entry wrapper. (Get_Prim_Op_Kind, Set_Prim_Op_Kind): Set and retrieve the kind of callable entity of a primitive operation. * exp_ch3.adb (Freeze_Record_Type): Generate the declarations of the primitive operations used in dispatching selects for limited interfaces, limited tagged, task and protected types what implement a limited interface. (Freeze_Type): Generate the bodies of the primitive operations used in dispatching selects for limited tagged, task and protected types that implement a limited interface. Generate statements to populate the two auxiliary tables used for dispatching in select statements. (Freeze_Record_Type): Add call to initialize the dispatch table entries associated with predefined interface primitive operations. (Build_Dcheck_Function): Change Set_Subtype_Mark to Set_Result_Definition. (Build_Variant_Record_Equality): Change Subtype_Mark to Result_Definition. (Freeze_Enumeration_Type): Change Subtype_Mark to Result_Definition. (Predef_Spec_Or_Body): Change Subtype_Mark to Result_Definition. (Build_Assignment): Simplify the code that adds the run-time-check. (Expand_N_Object_Declaration): Code cleanup. * exp_ch7.adb (Make_Clean): Select the appropriate type for locking entries when there is a protected type that implements a limited interface. * exp_ch9.adb: Add package Select_Expansion_Utilities that contains common routines used in expansion of dispatching selects. (Add_Private_Declarations): Select the appropriate protection type when there is a protected type that implements a limited interface. (Build_Parameter_Block): Generate a wrapped parameter block. (Build_Protected_Subprogram_Body): Select the appropriate type for locking entries when there is a protected type that implements a limited interface. (Build_Wrapper_Spec): Set the flag and wrapped entity for procedures classified as entry wrappers. (Expand_N_Asynchronous_Select): Add support for expansion of dispatching asynchronous selects. (Expand_N_Conditional_Entry_Call): Add support for expansion of dispatching conditional selects. (Expand_N_Protected_Type_Declaration): Select the appropriate type for protection when there is a protected type that implements limited interfaces. (Expand_N_Timed_Entry_Call): Add support for expansion of dispatching timed selects. (Extract_Dispatching_Call): Extract the entity of the name of a dispatching call, the object parameter, actual parameters and corresponding formals. (Make_Initialize_Protection): Correct logic of protection initialization when there is a protected type that implements a limited interface. (Parameter_Block_Pack): Populate a wrapped parameter block with the values of actual parameters. (Parameter_Block_Unpack): Retrieve the values from a wrapped parameter block and assign them to the original actual parameters. * exp_ch9.ads (Subprogram_Protection_Mode): New type. (Build_Protected_Sub_Specification): Change the type and name of the last formal to account for the increased variety of protection modes. * einfo.ads, einfo.adb (Was_Hidden): New attribute. Present in all entities. Used to save the value of the Is_Hidden attribute when the limited-view is installed. (Is_Primitive_Wrapper, Set_Is_Primitive_Wrapper): Retrieve and change the attribute of procedures classified as entry wrappers. (Wrapped_Entity, Set_Wrapped_Entity): Retrieve and change the wrapped entity of a primitive wrapper. (Write_Entity_Flags): Output the name and value of the Is_Primitive_Wrapper attribute. (Write_Field27_Name): Output the name and entity of the field Wrapped_ Entity. (Underlying_Type): If we have an incomplete entity that comes from the limited view then we return the Underlying_Type of its non-limited view if it is already available. (Abstract_Interface_Alias): Flag applies to all subrogram kinds, including operators. (Write_Field26_Name): Add entry for Overridden_Operation (Overridden_Operation): New attribute of functions and procedures. * exp_disp.ads, exp_disp.adb (Default_Prim_Op_Position): Return a predefined position in the dispatch table for the primitive operations used in dispatching selects. (Init_Predefined_Interface_Primitives): Remove the hardcoded number of predefined primitive operations and replace it with Default_Prim_Op_Count. (Make_Disp_Asynchronous_Select_Spec, Make_Disp_Conditional_Select_Spec, Make_Disp_Get_Prim_Op_Kind_Spec, Make_Disp_Timed_Select_Spec): Update the names of the generated primitive operations used in dispatching selects. (Init_Predefined_Interface_Primitives): No need to inherit primitives in case of abstract interface types. They will be inherit by the objects implementing the interface. (Make_DT): There is no need to inherit the dispatch table of the ancestor interface for the elaboration of abstract interface types. The dispatch table will be inherited by the object implementing the interface. (Copy_Secondary_DTs): Add documentation. (Validate_Position): Improve this static check in case of aliased subprograms because aliased subprograms must have the same position. (Init_Predefined_Interface_Primitives): New subprogram that initializes the entries associated with predefined primitives of all the secondary dispatch tables. (Build_Anonymous_Access_Type): Removed. (Expand_Interface_Actuals): With the previous cleanup there is no need to build an anonymous access type. This allows further cleanup in the code generated by the expander. (Expand_Interface_Conversion): If the actual is an access type then build an internal function to handle the displacement. If the actual is null this function returns null because no displacement is required; otherwise performs a type conversion that will be expanded in the code that returns the value of the displaced actual. (Expand_Interface_Actuals): Avoid the generation of unnecessary type conversions that have no effect in the generated code because no displacement is required. Code cleanup; use local variables to avoid repeated calls to the subprogram directly_designated_type(). * exp_util.ads, exp_util.adb (Is_Predefined_Dispatching_Operation): Classify the primitive operations used in dispatching selects as predefined. (Implements_Limited_Interface): Determine whether some type either directly implements a limited interface or extends a type that implements a limited interface. (Build_Task_Image_Function): Change Subtype_Mark to Result_Definition. (Expand_Subtype_From_Expr): Do not build actual subtype if the expression is limited. (Find_Interface_Tag): Add code to handle class-wide types and entities from the limited-view. * rtsfind.ads: Add entries in RE_Id and RE_Unit_Table for Get_Entry_Index, Get_Prim_Op_Kind, POK_Function, POK_Procedure, POK_Protected_Entry, POK_Protected_Function, POK_Protected_Procedure, POK_Task_Entry, POK_Task_Procedure, Prim_Op_Kind, Set_Entry_Index, Set_Prim_Op_Kind. * sem_ch9.adb (Analyze_Triggering_Alternative): Check for legal type of procedure name or prefix that appears as a trigger in a triggering alternative. * uintp.ads: Introduce constants Uint_11 and Uint_13. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@103850 138bc75d-0d04-0410-961f-82ee72b054a4 --- diff --git a/gcc/ada/a-tags.adb b/gcc/ada/a-tags.adb index 56eaff9..4a21e15 100644 --- a/gcc/ada/a-tags.adb +++ b/gcc/ada/a-tags.adb @@ -65,27 +65,44 @@ package body Ada.Tags is -- | tags | -- +-------------------+ -- | table of | --- | interface | +-- : interface : -- | tags | -- +-------------------+ +-- | table of | +-- : primitive op : +-- | kinds | +-- +-------------------+ +-- | table of | +-- : entry : +-- | indices | +-- +-------------------+ subtype Cstring is String (Positive); type Cstring_Ptr is access all Cstring; + -- We suppress index checks because the declared size in the record below + -- is a dummy size of one (see below). + type Tag_Table is array (Natural range <>) of Tag; pragma Suppress_Initialization (Tag_Table); pragma Suppress (Index_Check, On => Tag_Table); - -- We suppress index checks because the declared size in the record below - -- is a dummy size of one (see below). + + type Prim_Op_Kind_Table is array (Natural range <>) of Prim_Op_Kind; + pragma Suppress_Initialization (Prim_Op_Kind_Table); + pragma Suppress (Index_Check, On => Prim_Op_Kind_Table); + + type Entry_Index_Table is array (Natural range <>) of Positive; + pragma Suppress_Initialization (Entry_Index_Table); + pragma Suppress (Index_Check, On => Entry_Index_Table); type Type_Specific_Data is record - Idepth : Natural; + Idepth : Natural; -- Inheritance Depth Level: Used to implement the membership test -- associated with single inheritance of tagged types in constant-time. -- In addition it also indicates the size of the first table stored in -- the Tags_Table component (see comment below). - Access_Level : Natural; + Access_Level : Natural; -- Accessibility level required to give support to Ada 2005 nested type -- extensions. This feature allows safe nested type extensions by -- shifting the accessibility checks to certain operations, rather than @@ -94,20 +111,20 @@ package body Ada.Tags is -- function return, and class-wide stream I/O, the danger of objects -- outliving their type declaration can be eliminated (Ada 2005: AI-344) - Expanded_Name : Cstring_Ptr; - External_Tag : Cstring_Ptr; - HT_Link : Tag; + Expanded_Name : Cstring_Ptr; + External_Tag : Cstring_Ptr; + HT_Link : Tag; -- Components used to give support to the Ada.Tags subprograms described -- in ARM 3.9 Remotely_Callable : Boolean; -- Used to check ARM E.4 (18) - RC_Offset : SSE.Storage_Offset; + RC_Offset : SSE.Storage_Offset; -- Controller Offset: Used to give support to tagged controlled objects -- (see Get_Deep_Controller at s-finimp) - Num_Interfaces : Natural; + Num_Interfaces : Natural; -- Number of abstract interface types implemented by the tagged type. -- The value Idepth+Num_Interfaces indicates the end of the second table -- stored in the Tags_Table component. It is used to implement the @@ -121,6 +138,16 @@ package body Ada.Tags is -- purpose we are using the same mechanism as for the Prims_Ptr array in -- the Dispatch_Table record. See comments below on Prims_Ptr for -- further details. + + POK_Table : Prim_Op_Kind_Table (1 .. 1); + Ent_Index_Table : Entry_Index_Table (1 .. 1); + -- Two auxiliary tables used for dispatching in asynchronous, + -- conditional and timed selects. Their size depends on the number + -- of primitive operations. Indexing in these two tables is performed + -- by subtracting the number of predefined primitive operations from + -- the given index value. POK_Table contains the callable entity kinds + -- of all non-predefined primitive operations. Ent_Index_Table contains + -- the entry index of primitive entry wrappers. end record; type Dispatch_Table is record @@ -175,7 +202,7 @@ package body Ada.Tags is type Storage_Offset_Ptr is access System.Storage_Elements.Storage_Offset; function To_Storage_Offset_Ptr is - new Unchecked_Conversion (System.Address, Storage_Offset_Ptr); + new Unchecked_Conversion (System.Address, Storage_Offset_Ptr); ----------------------- -- Local Subprograms -- @@ -242,15 +269,12 @@ package body Ada.Tags is Str1 : constant Cstring_Ptr := To_Cstring_Ptr (A); Str2 : constant Cstring_Ptr := To_Cstring_Ptr (B); J : Integer := 1; - begin loop if Str1 (J) /= Str2 (J) then return False; - elsif Str1 (J) = ASCII.NUL then return True; - else J := J + 1; end if; @@ -330,22 +354,27 @@ package body Ada.Tags is -- that are contained in the dispatch table referenced by Obj'Tag. function IW_Membership - (This : System.Address; - Iface_Tag : Tag) return Boolean + (This : System.Address; + T : Tag) return Boolean is - T : constant Tag := To_Tag_Ptr (This).all; - Obj_Base : constant System.Address := This - Offset_To_Top (T); - T_Base : constant Tag := To_Tag_Ptr (Obj_Base).all; + Curr_DT : constant Tag := To_Tag_Ptr (This).all; + Obj_Base : constant System.Address := This - Offset_To_Top (Curr_DT); + Obj_DT : constant Tag := To_Tag_Ptr (Obj_Base).all; - Obj_TSD : constant Type_Specific_Data_Ptr := TSD (T_Base); - Last_Id : constant Natural := Obj_TSD.Idepth + Obj_TSD.Num_Interfaces; - Id : Natural; + Obj_TSD : constant Type_Specific_Data_Ptr := TSD (Obj_DT); + Last_Id : constant Natural := Obj_TSD.Idepth + Obj_TSD.Num_Interfaces; + Id : Natural; begin if Obj_TSD.Num_Interfaces > 0 then - Id := Obj_TSD.Idepth + 1; + + -- Traverse the ancestor tags table plus the interface tags table. + -- The former part is required to give support to: + -- Iface_CW in Typ'Class + + Id := 0; loop - if Obj_TSD.Tags_Table (Id) = Iface_Tag then + if Obj_TSD.Tags_Table (Id) = T then return True; end if; @@ -413,6 +442,17 @@ package body Ada.Tags is return TSD (T).Access_Level; end Get_Access_Level; + --------------------- + -- Get_Entry_Index -- + --------------------- + + function Get_Entry_Index + (T : Tag; + Position : Positive) return Positive is + begin + return TSD (T).Ent_Index_Table (Position - Default_Prim_Op_Count); + end Get_Entry_Index; + ---------------------- -- Get_External_Tag -- ---------------------- @@ -433,6 +473,17 @@ package body Ada.Tags is return T.Prims_Ptr (Position); end Get_Prim_Op_Address; + ---------------------- + -- Get_Prim_Op_Kind -- + ---------------------- + + function Get_Prim_Op_Kind + (T : Tag; + Position : Positive) return Prim_Op_Kind is + begin + return TSD (T).POK_Table (Position - Default_Prim_Op_Count); + end Get_Prim_Op_Kind; + ------------------- -- Get_RC_Offset -- ------------------- @@ -485,9 +536,9 @@ package body Ada.Tags is -- of the parent New_TSD_Ptr.Tags_Table - (1 .. New_TSD_Ptr.Idepth + New_TSD_Ptr.Num_Interfaces) - := Old_TSD_Ptr.Tags_Table - (0 .. Old_TSD_Ptr.Idepth + Old_TSD_Ptr.Num_Interfaces); + (1 .. New_TSD_Ptr.Idepth + New_TSD_Ptr.Num_Interfaces) := + Old_TSD_Ptr.Tags_Table + (0 .. Old_TSD_Ptr.Idepth + Old_TSD_Ptr.Num_Interfaces); else New_TSD_Ptr.Idepth := 0; New_TSD_Ptr.Num_Interfaces := 0; @@ -588,8 +639,8 @@ package body Ada.Tags is -- The tag of the parent type through the dispatch table F : constant Acc_Size := To_Acc_Size (Parent_Tag.Prims_Ptr (1)); - -- Access to the _size primitive of the parent. We assume that - -- it is always in the first slot of the dispatch table + -- Access to the _size primitive of the parent. We assume that it is + -- always in the first slot of the dispatch table begin -- Here we compute the size of the _parent field of the object @@ -672,6 +723,18 @@ package body Ada.Tags is TSD (T).Access_Level := Value; end Set_Access_Level; + --------------------- + -- Set_Entry_Index -- + --------------------- + + procedure Set_Entry_Index + (T : Tag; + Position : Positive; + Value : Positive) is + begin + TSD (T).Ent_Index_Table (Position - Default_Prim_Op_Count) := Value; + end Set_Entry_Index; + ----------------------- -- Set_Expanded_Name -- ----------------------- @@ -718,6 +781,18 @@ package body Ada.Tags is T.Prims_Ptr (Position) := Value; end Set_Prim_Op_Address; + ---------------------- + -- Set_Prim_Op_Kind -- + ---------------------- + + procedure Set_Prim_Op_Kind + (T : Tag; + Position : Positive; + Value : Prim_Op_Kind) is + begin + TSD (T).POK_Table (Position - Default_Prim_Op_Count) := Value; + end Set_Prim_Op_Kind; + ------------------- -- Set_RC_Offset -- ------------------- diff --git a/gcc/ada/a-tags.ads b/gcc/ada/a-tags.ads index 57859b6..34d7d63 100644 --- a/gcc/ada/a-tags.ads +++ b/gcc/ada/a-tags.ads @@ -40,11 +40,8 @@ with System.Storage_Elements; with Unchecked_Conversion; package Ada.Tags is -pragma Preelaborate_05 (Tags); --- In accordance with Ada 2005 AI-362 - - pragma Elaborate_Body; - -- We need a dummy body to solve bootstrap path issues (why ???) + pragma Preelaborate_05; + -- In accordance with Ada 2005 AI-362 type Tag is private; @@ -101,6 +98,29 @@ private type Type_Specific_Data; type Type_Specific_Data_Ptr is access all Type_Specific_Data; + -- Primitive operation kinds. These values differentiate the kinds of + -- callable entities stored in the dispatch table. Certain kinds may + -- not be used, but are added for completeness. + + type Prim_Op_Kind is + (POK_Function, + POK_Procedure, + POK_Protected_Entry, + POK_Protected_Function, + POK_Protected_Procedure, + POK_Task_Entry, + POK_Task_Procedure); + + -- Number of predefined primitive operations added by the Expander + -- for a tagged type. It is utilized for indexing in the two auxiliary + -- tables used for dispatching asynchronous, conditional and timed + -- selects. In order to be space efficien, indexing is performed by + -- subtracting this constant value from the provided position in the + -- auxiliary tables. + -- This value is mirrored from Exp_Disp.ads. + + Default_Prim_Op_Count : constant Positive := 14; + package SSE renames System.Storage_Elements; function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean; @@ -108,15 +128,31 @@ private -- true if Obj is in Typ'Class. function IW_Membership - (This : System.Address; - Iface_Tag : Tag) return Boolean; - -- Ada 2005 (AI-251): Given the tag of an object and the tag associated - -- with an interface, return true if Obj is in Iface'Class. + (This : System.Address; + T : Tag) return Boolean; + -- Ada 2005 (AI-251): General routine that checks if a given object + -- implements a tagged type. Its common usage is to check if Obj is in + -- Iface'Class, but it is also used to check if a class-wide interface + -- implements a given type (Iface_CW_Typ in T'Class). For example: + -- + -- type I is interface; + -- type T is tagged ... + -- + -- function Test (O : in I'Class) is + -- begin + -- return O in T'Class. + -- end Test; function Get_Access_Level (T : Tag) return Natural; -- Given the tag associated with a type, returns the accessibility level -- of the type. + function Get_Entry_Index + (T : Tag; + Position : Positive) return Positive; + -- Return a primitive operation's entry index (if entry) given a dispatch + -- table T and a position of a primitive operation in T. + function Get_External_Tag (T : Tag) return System.Address; -- Retrieve the address of a null terminated string containing -- the external name @@ -124,10 +160,16 @@ private function Get_Prim_Op_Address (T : Tag; Position : Positive) return System.Address; - -- Given a pointer to a dispatch Table (T) and a position in the DT + -- Given a pointer to a dispatch table (T) and a position in the DT -- this function returns the address of the virtual function stored -- in it (used for dispatching calls) + function Get_Prim_Op_Kind + (T : Tag; + Position : Positive) return Prim_Op_Kind; + -- Return a primitive operation's kind given a dispatch table T and a + -- position of a primitive operation in T. + function Get_RC_Offset (T : Tag) return SSE.Storage_Offset; -- Return the Offset of the implicit record controller when the object -- has controlled components. O otherwise. @@ -173,6 +215,13 @@ private -- Insert the Tag and its associated external_tag in a table for the -- sake of Internal_Tag + procedure Set_Entry_Index + (T : Tag; + Position : Positive; + Value : Positive); + -- Set the entry index of a primitive operation in T's TSD table indexed + -- by Position. + procedure Set_Offset_To_Top (T : Tag; Value : System.Storage_Elements.Storage_Offset); @@ -185,13 +234,20 @@ private (T : Tag; Position : Positive; Value : System.Address); - -- Given a pointer to a dispatch Table (T) and a position in the - -- dispatch Table put the address of the virtual function in it - -- (used for overriding) + -- Given a pointer to a dispatch Table (T) and a position in the dispatch + -- Table put the address of the virtual function in it (used for + -- overriding). + + procedure Set_Prim_Op_Kind + (T : Tag; + Position : Positive; + Value : Prim_Op_Kind); + -- Set the kind of a primitive operation in T's TSD table indexed by + -- Position. procedure Set_TSD (T : Tag; Value : System.Address); -- Given a pointer T to a dispatch Table, stores the address of the record - -- containing the Type Specific Data generated by GNAT + -- containing the Type Specific Data generated by GNAT. procedure Set_Access_Level (T : Tag; Value : Natural); -- Sets the accessibility level of the tagged type associated with T @@ -199,11 +255,11 @@ private procedure Set_Expanded_Name (T : Tag; Value : System.Address); -- Set the address of the string containing the expanded name - -- in the Dispatch table + -- in the Dispatch table. procedure Set_External_Tag (T : Tag; Value : System.Address); -- Set the address of the string containing the external tag - -- in the Dispatch table + -- in the Dispatch table. procedure Set_RC_Offset (T : Tag; Value : SSE.Storage_Offset); -- Sets the Offset of the implicit record controller when the object diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index cd285b4..db44614 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -215,9 +215,9 @@ package body Einfo is -- Abstract_Interface_Alias Node25 - -- (unused) Node26 + -- Overridden_Operation Node26 - -- (unused) Node27 + -- Wrapped_Entity Node27 --------------------------------------------- -- Usage of Flags in Defining Entity Nodes -- @@ -442,9 +442,9 @@ package body Einfo is -- Has_Specified_Stream_Read Flag192 -- Has_Specified_Stream_Write Flag193 -- Is_Local_Anonymous_Access Flag194 + -- Is_Primitive_Wrapper Flag195 + -- Was_Hidden Flag196 - -- (unused) Flag195 - -- (unused) Flag196 -- (unused) Flag197 -- (unused) Flag198 -- (unused) Flag199 @@ -512,8 +512,7 @@ package body Einfo is function Abstract_Interface_Alias (Id : E) return E is begin - pragma Assert - (Ekind (Id) = E_Procedure or Ekind (Id) = E_Function); + pragma Assert (Is_Subprogram (Id)); return Node25 (Id); end Abstract_Interface_Alias; @@ -1734,6 +1733,12 @@ package body Einfo is return Flag59 (Id); end Is_Preelaborated; + function Is_Primitive_Wrapper (Id : E) return B is + begin + pragma Assert (Ekind (Id) = E_Procedure); + return Flag195 (Id); + end Is_Primitive_Wrapper; + function Is_Private_Composite (Id : E) return B is begin pragma Assert (Is_Type (Id)); @@ -2038,6 +2043,11 @@ package body Einfo is return Node22 (Id); end Original_Record_Component; + function Overridden_Operation (Id : E) return E is + begin + return Node26 (Id); + end Overridden_Operation; + function Packed_Array_Type (Id : E) return E is begin pragma Assert (Is_Array_Type (Id)); @@ -2325,6 +2335,18 @@ package body Einfo is return Flag96 (Id); end Warnings_Off; + function Wrapped_Entity (Id : E) return E is + begin + pragma Assert (Ekind (Id) = E_Procedure + and then Is_Primitive_Wrapper (Id)); + return Node27 (Id); + end Wrapped_Entity; + + function Was_Hidden (Id : E) return B is + begin + return Flag196 (Id); + end Was_Hidden; + ------------------------------ -- Classification Functions -- ------------------------------ @@ -3799,6 +3821,12 @@ package body Einfo is Set_Flag59 (Id, V); end Set_Is_Preelaborated; + procedure Set_Is_Primitive_Wrapper (Id : E; V : B := True) is + begin + pragma Assert (Ekind (Id) = E_Procedure); + Set_Flag195 (Id, V); + end Set_Is_Primitive_Wrapper; + procedure Set_Is_Private_Composite (Id : E; V : B := True) is begin pragma Assert (Is_Type (Id)); @@ -4107,6 +4135,11 @@ package body Einfo is Set_Node22 (Id, V); end Set_Original_Record_Component; + procedure Set_Overridden_Operation (Id : E; V : E) is + begin + Set_Node26 (Id, V); + end Set_Overridden_Operation; + procedure Set_Packed_Array_Type (Id : E; V : E) is begin pragma Assert (Is_Array_Type (Id)); @@ -4400,6 +4433,18 @@ package body Einfo is Set_Flag96 (Id, V); end Set_Warnings_Off; + procedure Set_Was_Hidden (Id : E; V : B := True) is + begin + Set_Flag196 (Id, V); + end Set_Was_Hidden; + + procedure Set_Wrapped_Entity (Id : E; V : E) is + begin + pragma Assert (Ekind (Id) = E_Procedure + and then Is_Primitive_Wrapper (Id)); + Set_Node27 (Id, V); + end Set_Wrapped_Entity; + ----------------------------------- -- Field Initialization Routines -- ----------------------------------- @@ -6328,6 +6373,15 @@ package body Einfo is return Underlying_Type (Full_View (Id)); end if; + -- If we have an incomplete entity that comes from the limited + -- view then we return the Underlying_Type of its non-limited + -- view. + + elsif From_With_Type (Id) + and then Present (Non_Limited_View (Id)) + then + return Underlying_Type (Non_Limited_View (Id)); + -- Otherwise check for the case where we have a derived type or -- subtype, and if so get the Underlying_Type of the parent type. @@ -6538,6 +6592,7 @@ package body Einfo is W ("Is_Packed_Array_Type", Flag138 (Id)); W ("Is_Potentially_Use_Visible", Flag9 (Id)); W ("Is_Preelaborated", Flag59 (Id)); + W ("Is_Primitive_Wrapper", Flag195 (Id)); W ("Is_Private_Composite", Flag107 (Id)); W ("Is_Private_Descendant", Flag53 (Id)); W ("Is_Public", Flag10 (Id)); @@ -6589,6 +6644,7 @@ package body Einfo is W ("Uses_Sec_Stack", Flag95 (Id)); W ("Vax_Float", Flag151 (Id)); W ("Warnings_Off", Flag96 (Id)); + W ("Was_Hidden", Flag196 (Id)); end Write_Entity_Flags; ----------------------- @@ -7504,6 +7560,10 @@ package body Einfo is procedure Write_Field26_Name (Id : Entity_Id) is begin case Ekind (Id) is + when E_Procedure | + E_Function => + Write_Str ("Overridden_Operation"); + when others => Write_Str ("Field26??"); end case; @@ -7516,6 +7576,9 @@ package body Einfo is procedure Write_Field27_Name (Id : Entity_Id) is begin case Ekind (Id) is + when E_Procedure => + Write_Str ("Wrapped_Entity"); + when others => Write_Str ("Field27??"); end case; diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 4ba4ad9..189a9ec 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -183,7 +183,7 @@ package Einfo is -- dynamic bounds, it is assumed that the value can range down or up -- to the corresponding bound of the ancestor --- The RM defined attribute Size corresponds to the Value_Size attribute. +-- The RM defined attribute Size corresponds to the Value_Size attribute -- The Size attribute may be defined for a first-named subtype. This sets -- the Value_Size of the first-named subtype to the given value, and the @@ -2243,6 +2243,11 @@ package Einfo is -- flag is set does not necesarily mean that no elaboration code is -- generated for the package. +-- Is_Primitive_Wrapper (Flag195) +-- Present in E_Procedures. Primitive wrappers are Expander-generated +-- procedures that wrap entries of protected or task types implementing +-- a limited interface. + -- Is_Private_Composite (Flag107) -- Present in composite types that have a private component. Used to -- enforce the rule that operations on the composite type that depend @@ -2769,6 +2774,10 @@ package Einfo is -- In subtypes (tagged and untagged): -- Points to the component in the base type. +-- Overridden_Operation (Node26) +-- Present in subprograms. For overriding operations, points to the +-- user-defined parent subprogram that is being overridden. + -- Packed_Array_Type (Node23) -- Present in array types and subtypes, including the string literal -- subtype case, if the corresponding type is packed (either bit packed @@ -3220,6 +3229,14 @@ package Einfo is -- is used to suppress warnings for a given entity. It is also used by -- the compiler in some situations to kill spurious warnings. +-- Was_Hidden (Flag196) +-- Present in all entities. Used to save the value of the Is_Hidden +-- attribute when the limited-view is installed (Ada 2005: AI-217). + +-- Wrapped_Entity (Node27) +-- Present in an E_Procedure classified as a Is_Primitive_Wrapper. Set +-- to the entity that is being wrapped. + ------------------ -- Access Kinds -- ------------------ @@ -3488,7 +3505,7 @@ package Einfo is -- A record type, created by a record type declaration E_Record_Subtype, - -- A record subtype, created by a record subtype declaration. + -- A record subtype, created by a record subtype declaration E_Record_Type_With_Private, -- Used for types defined by a private extension declaration, and @@ -3499,7 +3516,7 @@ package Einfo is -- a private type. E_Record_Subtype_With_Private, - -- A subtype of a type defined by a private extension declaration. + -- A subtype of a type defined by a private extension declaration E_Private_Type, -- A private type, created by a private type declaration @@ -4033,6 +4050,7 @@ package Einfo is -- Is_Packed_Array_Type (Flag138) -- Is_Potentially_Use_Visible (Flag9) -- Is_Preelaborated (Flag59) + -- Is_Primitive_Wrapper (Flag195) -- Is_Public (Flag10) -- Is_Pure (Flag44) -- Is_Remote_Call_Interface (Flag62) @@ -4050,6 +4068,7 @@ package Einfo is -- Referenced_As_LHS (Flag36) -- Suppress_Elaboration_Warnings (Flag148) -- Suppress_Style_Checks (Flag165) + -- Was_Hidden (Flag196) -- Declaration_Node (synth) -- Enclosing_Dynamic_Scope (synth) @@ -4401,6 +4420,7 @@ package Einfo is -- Privals_Chain (Elist23) (for a protected function) -- Obsolescent_Warning (Node24) -- Abstract_Interface_Alias (Node25) + -- Overridden_Operation (Node26) -- Body_Needed_For_SAL (Flag40) -- Elaboration_Entity_Required (Flag174) -- Function_Returns_With_DSP (Flag169) @@ -4648,6 +4668,9 @@ package Einfo is -- Privals_Chain (Elist23) (for a protected procedure) -- Obsolescent_Warning (Node24) -- Abstract_Interface_Alias (Node25) + -- Overridden_Operation (Node26) + -- Wrapped_Entity (Node27) (non-generic case only) + -- Body_Needed_For_SAL (Flag40) -- Elaboration_Entity_Required (Flag174) -- Function_Returns_With_DSP (Flag169) (always False for procedure) @@ -4673,6 +4696,8 @@ package Einfo is -- Is_Machine_Code_Subprogram (Flag137) (non-generic case only) -- Is_Null_Init_Proc (Flag178) -- Is_Overriding_Operation (Flag39) (non-generic case only) + -- Is_Primitive_Wrapper (Flag195) (non-generic case only) + -- Is_Private_Descendant (Flag53) -- Is_Pure (Flag44) -- Is_Thread_Body (Flag77) (non-generic case only) @@ -5299,6 +5324,8 @@ package Einfo is function Is_Packed_Array_Type (Id : E) return B; function Is_Potentially_Use_Visible (Id : E) return B; function Is_Preelaborated (Id : E) return B; + function Is_Primitive_Wrapper (Id : E) return B; + function Is_Private_Composite (Id : E) return B; function Is_Private_Descendant (Id : E) return B; function Is_Public (Id : E) return B; @@ -5351,6 +5378,7 @@ package Einfo is function Original_Access_Type (Id : E) return E; function Original_Array_Type (Id : E) return E; function Original_Record_Component (Id : E) return E; + function Overridden_Operation (Id : E) return E; function Packed_Array_Type (Id : E) return E; function Parent_Subtype (Id : E) return E; function Primitive_Operations (Id : E) return L; @@ -5402,6 +5430,8 @@ package Einfo is function Uses_Sec_Stack (Id : E) return B; function Vax_Float (Id : E) return B; function Warnings_Off (Id : E) return B; + function Was_Hidden (Id : E) return B; + function Wrapped_Entity (Id : E) return E; ------------------------------- -- Classification Attributes -- @@ -5792,6 +5822,8 @@ package Einfo is procedure Set_Is_Packed_Array_Type (Id : E; V : B := True); procedure Set_Is_Potentially_Use_Visible (Id : E; V : B := True); procedure Set_Is_Preelaborated (Id : E; V : B := True); + procedure Set_Is_Primitive_Wrapper (Id : E; V : B := True); + procedure Set_Is_Private_Composite (Id : E; V : B := True); procedure Set_Is_Private_Descendant (Id : E; V : B := True); procedure Set_Is_Public (Id : E; V : B := True); @@ -5843,6 +5875,7 @@ package Einfo is procedure Set_Original_Access_Type (Id : E; V : E); procedure Set_Original_Array_Type (Id : E; V : E); procedure Set_Original_Record_Component (Id : E; V : E); + procedure Set_Overridden_Operation (Id : E; V : E); procedure Set_Packed_Array_Type (Id : E; V : E); procedure Set_Parent_Subtype (Id : E; V : E); procedure Set_Primitive_Operations (Id : E; V : L); @@ -5894,6 +5927,8 @@ package Einfo is procedure Set_Uses_Sec_Stack (Id : E; V : B := True); procedure Set_Vax_Float (Id : E; V : B := True); procedure Set_Warnings_Off (Id : E; V : B := True); + procedure Set_Was_Hidden (Id : E; V : B := True); + procedure Set_Wrapped_Entity (Id : E; V : E); ----------------------------------- -- Field Initialization Routines -- @@ -6360,6 +6395,8 @@ package Einfo is pragma Inline (Is_Packed_Array_Type); pragma Inline (Is_Potentially_Use_Visible); pragma Inline (Is_Preelaborated); + pragma Inline (Is_Primitive_Wrapper); + pragma Inline (Is_Private_Composite); pragma Inline (Is_Private_Descendant); pragma Inline (Is_Private_Type); @@ -6421,6 +6458,7 @@ package Einfo is pragma Inline (Original_Access_Type); pragma Inline (Original_Array_Type); pragma Inline (Original_Record_Component); + pragma Inline (Overridden_Operation); pragma Inline (Packed_Array_Type); pragma Inline (Parameter_Mode); pragma Inline (Parent_Subtype); @@ -6473,6 +6511,8 @@ package Einfo is pragma Inline (Uses_Sec_Stack); pragma Inline (Vax_Float); pragma Inline (Warnings_Off); + pragma Inline (Was_Hidden); + pragma Inline (Wrapped_Entity); pragma Inline (Init_Alignment); pragma Inline (Init_Component_Bit_Offset); @@ -6692,6 +6732,8 @@ package Einfo is pragma Inline (Set_Is_Packed_Array_Type); pragma Inline (Set_Is_Potentially_Use_Visible); pragma Inline (Set_Is_Preelaborated); + pragma Inline (Set_Is_Primitive_Wrapper); + pragma Inline (Set_Is_Private_Composite); pragma Inline (Set_Is_Private_Descendant); pragma Inline (Set_Is_Public); @@ -6743,6 +6785,7 @@ package Einfo is pragma Inline (Set_Original_Access_Type); pragma Inline (Set_Original_Array_Type); pragma Inline (Set_Original_Record_Component); + pragma Inline (Set_Overridden_Operation); pragma Inline (Set_Packed_Array_Type); pragma Inline (Set_Parent_Subtype); pragma Inline (Set_Primitive_Operations); @@ -6794,6 +6837,8 @@ package Einfo is pragma Inline (Set_Uses_Sec_Stack); pragma Inline (Set_Vax_Float); pragma Inline (Set_Warnings_Off); + pragma Inline (Set_Was_Hidden); + pragma Inline (Set_Wrapped_Entity); -- END XEINFO INLINES diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 465a792..4b82921 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -27,7 +27,6 @@ with Atree; use Atree; with Checks; use Checks; with Einfo; use Einfo; -with Elists; use Elists; with Errout; use Errout; with Exp_Aggr; use Exp_Aggr; with Exp_Ch4; use Exp_Ch4; @@ -867,8 +866,8 @@ package body Exp_Ch3 is Parameter_List := Build_Discriminant_Formals (Rec_Id, False); Set_Parameter_Specifications (Spec_Node, Parameter_List); - Set_Subtype_Mark (Spec_Node, - New_Reference_To (Standard_Boolean, Loc)); + Set_Result_Definition (Spec_Node, + New_Reference_To (Standard_Boolean, Loc)); Set_Specification (Body_Node, Spec_Node); Set_Declarations (Body_Node, New_List); @@ -1482,16 +1481,21 @@ package body Exp_Ch3 is Attribute_Name => Name_Unrestricted_Access); end if; - -- Ada 2005 (AI-231): Generate conversion to the null-excluding - -- type to force the corresponding run-time check. + -- Ada 2005 (AI-231): Add the run-time check if required if Ada_Version >= Ada_05 - and then Can_Never_Be_Null (Etype (Id)) -- Lhs - and then Present (Etype (Exp)) - and then not Can_Never_Be_Null (Etype (Exp)) + and then Can_Never_Be_Null (Etype (Id)) -- Lhs then - Rewrite (Exp, Convert_To (Etype (Id), Relocate_Node (Exp))); - Analyze_And_Resolve (Exp, Etype (Id)); + if Nkind (Exp) = N_Null then + return New_List ( + Make_Raise_Constraint_Error (Sloc (Exp), + Reason => CE_Null_Not_Allowed)); + + elsif Present (Etype (Exp)) + and then not Can_Never_Be_Null (Etype (Exp)) + then + Install_Null_Excluding_Check (Exp); + end if; end if; -- Take a copy of Exp to ensure that later copies of this @@ -3017,7 +3021,7 @@ package body Exp_Ch3 is Make_Function_Specification (Loc, Defining_Unit_Name => F, Parameter_Specifications => Pspecs, - Subtype_Mark => New_Reference_To (Standard_Boolean, Loc)), + Result_Definition => New_Reference_To (Standard_Boolean, Loc)), Declarations => New_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, @@ -3698,19 +3702,6 @@ package body Exp_Ch3 is elsif Is_Access_Type (Typ) then - -- Ada 2005 (AI-231): Generate conversion to the null-excluding - -- type to force the corresponding run-time check - - if Ada_Version >= Ada_05 - and then (Can_Never_Be_Null (Def_Id) - or else Can_Never_Be_Null (Typ)) - then - Rewrite - (Expr_Q, - Convert_To (Etype (Def_Id), Relocate_Node (Expr_Q))); - Analyze_And_Resolve (Expr_Q, Etype (Def_Id)); - end if; - -- For access types set the Is_Known_Non_Null flag if the -- initializing value is known to be non-null. We can also set -- Can_Never_Be_Null if this is a constant. @@ -4362,7 +4353,7 @@ package body Exp_Ch3 is Make_Defining_Identifier (Loc, Name_uF), Parameter_Type => New_Reference_To (Standard_Boolean, Loc))), - Subtype_Mark => New_Reference_To (Standard_Integer, Loc)), + Result_Definition => New_Reference_To (Standard_Integer, Loc)), Declarations => Empty_List, @@ -4392,10 +4383,10 @@ package body Exp_Ch3 is ------------------------ procedure Freeze_Record_Type (N : Node_Id) is - Def_Id : constant Node_Id := Entity (N); Comp : Entity_Id; - Type_Decl : constant Node_Id := Parent (Def_Id); + Def_Id : constant Node_Id := Entity (N); Predef_List : List_Id; + Type_Decl : constant Node_Id := Parent (Def_Id); Renamed_Eq : Node_Id := Empty; -- Could use some comments ??? @@ -4534,6 +4525,7 @@ package body Exp_Ch3 is Make_Predefined_Primitive_Specs (Def_Id, Predef_List, Renamed_Eq); Insert_List_Before_And_Analyze (N, Predef_List); + Set_Is_Frozen (Def_Id, True); Set_All_DT_Position (Def_Id); @@ -4623,6 +4615,8 @@ package body Exp_Ch3 is Append_Freeze_Actions (Def_Id, Predefined_Primitive_Freeze (Def_Id)); + Append_Freeze_Actions + (Def_Id, Init_Predefined_Interface_Primitives (Def_Id)); end if; -- In the non-tagged case, an equality function is provided only for @@ -4696,8 +4690,20 @@ package body Exp_Ch3 is if Is_Tagged_Type (Def_Id) then Predef_List := Predefined_Primitive_Bodies (Def_Id, Renamed_Eq); Append_Freeze_Actions (Def_Id, Predef_List); - end if; + -- Populate the two auxiliary tables used for dispatching + -- asynchronous, conditional and timed selects for tagged + -- types that implement a limited interface. + + if Ada_Version >= Ada_05 + and then not Is_Interface (Def_Id) + and then not Is_Abstract (Def_Id) + and then not Is_Controlled (Def_Id) + and then Implements_Limited_Interface (Def_Id) + then + Append_Freeze_Actions (Def_Id, Make_Disp_Select_Tables (Def_Id)); + end if; + end if; end Freeze_Record_Type; ------------------------------ @@ -5887,6 +5893,67 @@ package body Exp_Ch3 is Parameter_Type => New_Reference_To (Tag_Typ, Loc))))); end if; + -- Generate the declarations for the following primitive operations: + -- disp_asynchronous_select + -- disp_conditional_select + -- disp_get_prim_op_kind + -- disp_timed_select + -- for limited interfaces and tagged types that implement a limited + -- interface. + + if Ada_Version >= Ada_05 + and then + ((Is_Interface (Tag_Typ) + and then Is_Limited_Record (Tag_Typ)) + or else + (not Is_Abstract (Tag_Typ) + and then not Is_Controlled (Tag_Typ) + and then Implements_Limited_Interface (Tag_Typ))) + then + if Is_Interface (Tag_Typ) then + Append_To (Res, + Make_Abstract_Subprogram_Declaration (Loc, + Specification => + Make_Disp_Asynchronous_Select_Spec (Tag_Typ))); + + Append_To (Res, + Make_Abstract_Subprogram_Declaration (Loc, + Specification => + Make_Disp_Conditional_Select_Spec (Tag_Typ))); + + Append_To (Res, + Make_Abstract_Subprogram_Declaration (Loc, + Specification => + Make_Disp_Get_Prim_Op_Kind_Spec (Tag_Typ))); + + Append_To (Res, + Make_Abstract_Subprogram_Declaration (Loc, + Specification => + Make_Disp_Timed_Select_Spec (Tag_Typ))); + + else + Append_To (Res, + Make_Subprogram_Declaration (Loc, + Specification => + Make_Disp_Asynchronous_Select_Spec (Tag_Typ))); + + Append_To (Res, + Make_Subprogram_Declaration (Loc, + Specification => + Make_Disp_Conditional_Select_Spec (Tag_Typ))); + + Append_To (Res, + Make_Subprogram_Declaration (Loc, + Specification => + Make_Disp_Get_Prim_Op_Kind_Spec (Tag_Typ))); + + Append_To (Res, + Make_Subprogram_Declaration (Loc, + Specification => + Make_Disp_Timed_Select_Spec (Tag_Typ))); + end if; + end if; + -- Specs for finalization actions that may be required in case a -- future extension contain a controlled element. We generate those -- only for root tagged types where they will get dummy bodies or @@ -6059,7 +6126,7 @@ package body Exp_Ch3 is Make_Function_Specification (Loc, Defining_Unit_Name => Id, Parameter_Specifications => Profile, - Subtype_Mark => + Result_Definition => New_Reference_To (Ret_Type, Loc)); end if; @@ -6242,6 +6309,29 @@ package body Exp_Ch3 is end if; end if; + -- Generate the bodies for the following primitive operations: + -- disp_asynchronous_select + -- disp_conditional_select + -- disp_get_prim_op_kind + -- disp_timed_select + -- for tagged types that implement a limited interface. + + if Ada_Version >= Ada_05 + and then not Is_Interface (Tag_Typ) + and then not Is_Abstract (Tag_Typ) + and then not Is_Controlled (Tag_Typ) + and then Implements_Limited_Interface (Tag_Typ) + then + Append_To (Res, + Make_Disp_Asynchronous_Select_Body (Tag_Typ)); + Append_To (Res, + Make_Disp_Conditional_Select_Body (Tag_Typ)); + Append_To (Res, + Make_Disp_Get_Prim_Op_Kind_Body (Tag_Typ)); + Append_To (Res, + Make_Disp_Timed_Select_Body (Tag_Typ)); + end if; + if not Is_Limited_Type (Tag_Typ) then -- Body for equality diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 1a202bc..f7d0119 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -1560,19 +1560,6 @@ package body Exp_Ch7 is end if; Set_Elaboration_Flag (N, Corresponding_Spec (N)); - - -- Generate a subprogram descriptor for the elaboration routine of - -- a package body if the package body has no pending instantiations - -- and it has generated at least one exception handler - - if Present (Handler_Records (Body_Entity (Ent))) - and then Is_Compilation_Unit (Ent) - and then not Delay_Subprogram_Descriptors (Body_Entity (Ent)) - then - Generate_Subprogram_Descriptor_For_Package - (N, Body_Entity (Ent)); - end if; - Set_In_Package_Body (Ent, False); -- Set to encode entity names in package body before gigi is called @@ -2220,6 +2207,8 @@ package body Exp_Ch7 is or else Has_Interrupt_Handler (Pid) or else (Has_Attach_Handler (Pid) and then not Restricted_Profile) + or else (Ada_Version >= Ada_05 + and then Present (Interface_List (Parent (Pid)))) then if Abort_Allowed or else Restriction_Active (No_Entry_Queue) = False diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 8759d02..6911d86 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -57,11 +57,261 @@ with Snames; use Snames; with Stand; use Stand; with Targparm; use Targparm; with Tbuild; use Tbuild; -with Types; use Types; with Uintp; use Uintp; package body Exp_Ch9 is + -------------------------------- + -- Select_Expansion_Utilities -- + -------------------------------- + + -- The following package contains helper routines used in the expansion of + -- dispatching asynchronous, conditional and timed selects. + + package Select_Expansion_Utilities is + function Build_Abort_Block + (Loc : Source_Ptr; + Blk_Ent : Entity_Id; + Blk : Node_Id) return Node_Id; + -- Generate: + -- begin + -- Blk + -- exception + -- when Abort_Signal => Abort_Undefer; + -- end; + -- Blk_Ent is the name of the encapsulated block, Blk is the actual + -- block node. + + function Build_B + (Loc : Source_Ptr; + Decls : List_Id) return Entity_Id; + -- Generate: + -- B : Boolean := False; + -- Append the object declaration to the list and return the name of + -- the object. + + function Build_C + (Loc : Source_Ptr; + Decls : List_Id) return Entity_Id; + -- Generate: + -- C : Ada.Tags.Prim_Op_Kind; + -- Append the object declaration to the list and return the name of + -- the object. + + function Build_Cleanup_Block + (Loc : Source_Ptr; + Blk_Ent : Entity_Id; + Stmts : List_Id; + Clean_Ent : Entity_Id) return Node_Id; + -- Generate: + -- declare + -- procedure _clean is + -- begin + -- ... + -- end _clean; + -- begin + -- Stmts + -- at end + -- _clean; + -- end; + -- Blk_Ent is the name of the generated block, Stmts is the list + -- of encapsulated statements and Clean_Ent is the parameter to + -- the _clean procedure. + + function Build_S + (Loc : Source_Ptr; + Decls : List_Id; + Call_Ent : Entity_Id) return Entity_Id; + -- Generate: + -- S : constant Integer := DT_Position (Call_Ent); + -- where Call_Ent is the entity of the dispatching call name. Append + -- the object declaration to the list and return the name of the + -- object. + + function Build_Wrapping_Procedure + (Loc : Source_Ptr; + Nam : Character; + Decls : List_Id; + Stmts : List_Id) return Entity_Id; + -- Generate: + -- procedure Nam is + -- begin + -- Stmts + -- end Nam; + -- where Nam is the generated procedure name and Stmts are the + -- encapsulated statements. Append the procedure body to Decls. + -- Return the internally generated procedure name. + end Select_Expansion_Utilities; + + package body Select_Expansion_Utilities is + + ----------------------- + -- Build_Abort_Block -- + ----------------------- + + function Build_Abort_Block + (Loc : Source_Ptr; + Blk_Ent : Entity_Id; + Blk : Node_Id) return Node_Id + is + begin + return + Make_Block_Statement (Loc, + Declarations => + No_List, + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => + New_List ( + Make_Implicit_Label_Declaration (Loc, + Defining_Identifier => + Blk_Ent, + Label_Construct => + Blk), + Blk), + + Exception_Handlers => + New_List ( + Make_Exception_Handler (Loc, + Exception_Choices => + New_List ( + New_Reference_To (Stand.Abort_Signal, Loc)), + Statements => + New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE ( + RE_Abort_Undefer), Loc), + Parameter_Associations => No_List)))))); + end Build_Abort_Block; + + ------------- + -- Build_B -- + ------------- + + function Build_B + (Loc : Source_Ptr; + Decls : List_Id) return Entity_Id + is + B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB); + + begin + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + B, + Object_Definition => + New_Reference_To (Standard_Boolean, Loc), + Expression => + New_Reference_To (Standard_False, Loc))); + + return B; + end Build_B; + + ------------- + -- Build_C -- + ------------- + + function Build_C + (Loc : Source_Ptr; + Decls : List_Id) return Entity_Id + is + C : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uC); + + begin + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + C, + Object_Definition => + New_Reference_To (RTE (RE_Prim_Op_Kind), Loc))); + + return C; + end Build_C; + + ------------------------- + -- Build_Cleanup_Block -- + ------------------------- + + function Build_Cleanup_Block + (Loc : Source_Ptr; + Blk_Ent : Entity_Id; + Stmts : List_Id; + Clean_Ent : Entity_Id) return Node_Id + is + Cleanup_Block : constant Node_Id := + Make_Block_Statement (Loc, + Identifier => New_Reference_To (Blk_Ent, Loc), + Declarations => No_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts), + Is_Asynchronous_Call_Block => True); + + begin + Set_Entry_Cancel_Parameter (Blk_Ent, Clean_Ent); + + return Cleanup_Block; + end Build_Cleanup_Block; + + ------------- + -- Build_S -- + ------------- + + function Build_S + (Loc : Source_Ptr; + Decls : List_Id; + Call_Ent : Entity_Id) return Entity_Id + is + S : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uS); + + begin + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => S, + Constant_Present => True, + Object_Definition => + New_Reference_To (Standard_Integer, Loc), + Expression => + Make_Integer_Literal (Loc, + Intval => DT_Position (Call_Ent)))); + + return S; + end Build_S; + + ------------------------------ + -- Build_Wrapping_Procedure -- + ------------------------------ + + function Build_Wrapping_Procedure + (Loc : Source_Ptr; + Nam : Character; + Decls : List_Id; + Stmts : List_Id) return Entity_Id + is + Proc_Nam : constant Entity_Id := + Make_Defining_Identifier (Loc, New_Internal_Name (Nam)); + begin + Append_To (Decls, + Make_Subprogram_Body (Loc, + Specification => + Make_Procedure_Specification (Loc, + Defining_Unit_Name => + Proc_Nam), + Declarations => + No_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => + New_Copy_List (Stmts)))); + + return Proc_Nam; + end Build_Wrapping_Procedure; + end Select_Expansion_Utilities; + + package SEU renames Select_Expansion_Utilities; + ----------------------- -- Local Subprograms -- ----------------------- @@ -76,17 +326,6 @@ package body Exp_Ch9 is -- the expression computed by this function uses the discriminants -- of the target task. - function Index_Constant_Declaration - (N : Node_Id; - Index_Id : Entity_Id; - Prot : Entity_Id) return List_Id; - -- For an entry family and its barrier function, we define a local entity - -- that maps the index in the call into the entry index into the object: - -- - -- I : constant Index_Type := Index_Type'Val ( - -- E - <> + - -- Protected_Entry_Index (Index_Type'Pos (Index_Type'First))); - procedure Add_Object_Pointer (Decls : List_Id; Pid : Entity_Id; @@ -96,7 +335,7 @@ package body Exp_Ch9 is -- of the System.Address pointer passed to entry barrier functions -- and entry body procedures. - function Build_Accept_Body (Astat : Node_Id) return Node_Id; + function Build_Accept_Body (Astat : Node_Id) return Node_Id; -- Transform accept statement into a block with added exception handler. -- Used both for simple accept statements and for accept alternatives in -- select statements. Astat is the accept statement. @@ -131,6 +370,23 @@ package body Exp_Ch9 is -- of the range of each entry family. A single array with that size is -- allocated for each concurrent object of the type. + function Build_Parameter_Block + (Loc : Source_Ptr; + Actuals : List_Id; + Formals : List_Id; + Decls : List_Id) return Entity_Id; + -- Generate an access type for each actual parameter in the list Actuals. + -- Cleate an encapsulating record that contains all the actuals and return + -- its type. Generate: + -- type Ann1 is access all + -- ... + -- type AnnN is access all + -- type Pnn is record + -- : Ann1; + -- ... + -- : AnnN; + -- end record; + function Build_Wrapper_Body (Loc : Source_Ptr; Proc_Nam : Entity_Id; @@ -272,6 +528,16 @@ package body Exp_Ch9 is -- to the use of 'Length on the index type, but must use Family_Offset -- to handle properly the case of bounds that depend on discriminants. + procedure Extract_Dispatching_Call + (N : Node_Id; + Call_Ent : out Entity_Id; + Object : out Entity_Id; + Actuals : out List_Id; + Formals : out List_Id); + -- Given a dispatching call, extract the entity of the name of the call, + -- its object parameter, its actual parameters and the formal parameters + -- of the overriden interface-level version. + procedure Extract_Entry (N : Node_Id; Concval : out Node_Id; @@ -289,6 +555,47 @@ 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 - <> + + -- Protected_Entry_Index (Index_Type'Pos (Index_Type'First))); + + function Parameter_Block_Pack + (Loc : Source_Ptr; + Blk_Typ : Entity_Id; + Actuals : List_Id; + Formals : List_Id; + Decls : List_Id; + Stmts : List_Id) return Node_Id; + -- Set the components of the generated parameter block with the values of + -- the actual parameters. Generate aliased temporaries to capture the + -- values for types that are passed by copy. Otherwise generate a reference + -- to the actual's value. Return the address of the aggregate block. + -- Generate: + -- Jnn1 : alias ; + -- Jnn1 := ; + -- ... + -- P : Blk_Typ := ( + -- Jnn1'unchecked_access; + -- 'reference; + -- ...); + + function Parameter_Block_Unpack + (Loc : Source_Ptr; + Actuals : List_Id; + Formals : List_Id) return List_Id; + -- Retrieve the values of the components from the parameter block and + -- assign then to the original actual parameters. Generate: + -- := P.; + -- ... + -- := P.; + 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 @@ -579,7 +886,13 @@ package body Exp_Ch9 is elsif Has_Interrupt_Handler (Typ) then Protection_Type := RE_Dynamic_Interrupt_Protection; - elsif Has_Entries (Typ) then + -- 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 if Abort_Allowed or else Restriction_Active (No_Entry_Queue) = False or else Number_Entries (Typ) > 1 @@ -836,7 +1149,7 @@ package body Exp_Ch9 is Parameter_Type => New_Reference_To (RTE (RE_Protected_Entry_Index), Loc))), - Subtype_Mark => New_Reference_To (Standard_Boolean, Loc)); + Result_Definition => New_Reference_To (Standard_Boolean, Loc)); end Build_Barrier_Function_Specification; -------------------------- @@ -998,9 +1311,92 @@ package body Exp_Ch9 is return Ecount; end Build_Entry_Count_Expression; - ------------------------------ + --------------------------- + -- Build_Parameter_Block -- + --------------------------- + + function Build_Parameter_Block + (Loc : Source_Ptr; + Actuals : List_Id; + Formals : List_Id; + Decls : List_Id) return Entity_Id + is + Actual : Entity_Id; + Comp_Nam : Node_Id; + Comp_Rec : Node_Id; + Comps : List_Id; + Formal : Entity_Id; + + begin + Actual := First (Actuals); + Comps := New_List; + Formal := Defining_Identifier (First (Formals)); + while Present (Actual) loop + -- Generate: + -- type Ann is access all + + Comp_Nam := + Make_Defining_Identifier (Loc, New_Internal_Name ('A')); + + Append_To (Decls, + Make_Full_Type_Declaration (Loc, + Defining_Identifier => + Comp_Nam, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => + True, + Constant_Present => + Ekind (Formal) = E_In_Parameter, + Subtype_Indication => + New_Reference_To (Etype (Actual), Loc)))); + + -- Generate: + -- Param : Ann; + + Append_To (Comps, + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Chars (Formal)), + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => + False, + Subtype_Indication => + New_Reference_To (Comp_Nam, Loc)))); + + Next_Actual (Actual); + Next_Formal_With_Extras (Formal); + end loop; + + -- Generate: + -- type Pnn is record + -- Param1 : Ann1; + -- ... + -- ParamN : AnnN; + + -- where Pnn is a parameter wrapping record, Param1 .. ParamN are the + -- original parameter names and Ann1 .. AnnN are the access to actual + -- types. + + Comp_Rec := + Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + + Append_To (Decls, + Make_Full_Type_Declaration (Loc, + Defining_Identifier => + Comp_Rec, + Type_Definition => + Make_Record_Definition (Loc, + Component_List => + Make_Component_List (Loc, Comps)))); + + return Comp_Rec; + end Build_Parameter_Block; + + ------------------------ -- Build_Wrapper_Body -- - ------------------------------ + ------------------------ function Build_Wrapper_Body (Loc : Source_Ptr; @@ -1370,7 +1766,10 @@ package body Exp_Ch9 is if Ekind (Proc_Nam) = E_Procedure or else Ekind (Proc_Nam) = E_Entry then - Set_Ekind (New_Name_Id, E_Procedure); + Set_Ekind (New_Name_Id, E_Procedure); + Set_Is_Primitive_Wrapper (New_Name_Id); + Set_Wrapped_Entity (New_Name_Id, Proc_Nam); + return Make_Procedure_Specification (Loc, Defining_Unit_Name => New_Name_Id, @@ -1378,11 +1777,13 @@ package body Exp_Ch9 is else pragma Assert (Ekind (Proc_Nam) = E_Function); Set_Ekind (New_Name_Id, E_Function); + return Make_Function_Specification (Loc, Defining_Unit_Name => New_Name_Id, Parameter_Specifications => New_Formals, - Subtype_Mark => New_Copy (Subtype_Mark (Parent (Proc_Nam)))); + Result_Definition => + New_Copy (Result_Definition (Parent (Proc_Nam)))); end if; end Build_Wrapper_Spec; @@ -1602,7 +2003,7 @@ package body Exp_Ch9 is Defining_Identifier => Parm2, Parameter_Type => New_Reference_To (RTE (RE_Protected_Entry_Index), Loc))), - Subtype_Mark => New_Occurrence_Of ( + Result_Definition => New_Occurrence_Of ( RTE (RE_Protected_Entry_Index), Loc)); end Build_Find_Body_Index_Spec; @@ -1895,19 +2296,23 @@ package body Exp_Ch9 is --------------------------------------- function Build_Protected_Sub_Specification - (N : Node_Id; - Prottyp : Entity_Id; - Unprotected : Boolean := False) return Node_Id + (N : Node_Id; + Prottyp : Entity_Id; + Mode : Subprogram_Protection_Mode) return Node_Id is - Loc : constant Source_Ptr := Sloc (N); - Decl : Node_Id; - Protnm : constant Name_Id := Chars (Prottyp); - Ident : Entity_Id; - Nam : Name_Id; - New_Id : Entity_Id; - New_Plist : List_Id; - Append_Char : Character; - New_Spec : Node_Id; + Loc : constant Source_Ptr := Sloc (N); + Decl : Node_Id; + Protnm : constant Name_Id := Chars (Prottyp); + Ident : Entity_Id; + Nam : Name_Id; + New_Id : Entity_Id; + New_Plist : List_Id; + New_Spec : Node_Id; + + Append_Chr : constant array (Subprogram_Protection_Mode) of Character := + (Dispatching_Mode => ' ', + Protected_Mode => 'P', + Unprotected_Mode => 'N'); begin if Ekind @@ -1921,26 +2326,14 @@ package body Exp_Ch9 is Ident := Defining_Unit_Name (Specification (Decl)); Nam := Chars (Ident); - New_Plist := Build_Protected_Spec - (Decl, Corresponding_Record_Type (Prottyp), - Unprotected, Ident); - - if Unprotected then - Append_Char := 'N'; - else - -- Ada 2005 (AI-345): The protected version no longer uses 'P' - -- as suffix in order to make it a primitive operation - - if Ada_Version >= Ada_05 then - Append_Char := ' '; - else - Append_Char := 'P'; - end if; - end if; + New_Plist := + Build_Protected_Spec (Decl, + Corresponding_Record_Type (Prottyp), + Mode = Unprotected_Mode, Ident); New_Id := Make_Defining_Identifier (Loc, - Chars => Build_Selected_Name (Protnm, Nam, Append_Char)); + Chars => Build_Selected_Name (Protnm, Nam, Append_Chr (Mode))); -- The unprotected operation carries the user code, and debugging -- information must be generated for it, even though this spec does @@ -1961,7 +2354,8 @@ package body Exp_Ch9 is Make_Function_Specification (Loc, Defining_Unit_Name => New_Id, Parameter_Specifications => New_Plist, - Subtype_Mark => New_Copy (Subtype_Mark (Specification (Decl)))); + Result_Definition => + New_Copy (Result_Definition (Specification (Decl)))); Set_Return_Present (Defining_Unit_Name (New_Spec)); return New_Spec; end if; @@ -2089,8 +2483,7 @@ package body Exp_Ch9 is Exc_Safe := Is_Exception_Safe (N); P_Op_Spec := - Build_Protected_Sub_Specification (N, - Pid, Unprotected => False); + Build_Protected_Sub_Specification (N, Pid, Protected_Mode); -- Build a list of the formal parameters of the protected -- version of the subprogram to use as the actual parameters @@ -2116,7 +2509,7 @@ package body Exp_Ch9 is Make_Object_Declaration (Loc, Defining_Identifier => R, Constant_Present => True, - Object_Definition => New_Copy (Subtype_Mark (N_Op_Spec)), + Object_Definition => New_Copy (Result_Definition (N_Op_Spec)), Expression => Make_Function_Call (Loc, Name => Make_Identifier (Loc, @@ -2162,7 +2555,10 @@ package body Exp_Ch9 is if Has_Entries (Pid) or else Has_Interrupt_Handler (Pid) - or else (Has_Attach_Handler (Pid) and then not Restricted_Profile) + or else (Has_Attach_Handler (Pid) + and then not Restricted_Profile) + or else (Ada_Version >= Ada_05 + and then Present (Interface_List (Parent (Pid)))) then if Abort_Allowed or else Restriction_Active (No_Entry_Queue) = False @@ -3004,8 +3400,7 @@ package body Exp_Ch9 is Op_Decls := Declarations (N); N_Op_Spec := - Build_Protected_Sub_Specification - (N, Pid, Unprotected => True); + Build_Protected_Sub_Specification (N, Pid, Unprotected_Mode); return Make_Subprogram_Body (Loc, @@ -3687,7 +4082,8 @@ package body Exp_Ch9 is Def1 := Make_Access_Function_Definition (Loc, Parameter_Specifications => P_List, - Subtype_Mark => New_Copy (Subtype_Mark (Type_Definition (N)))); + Result_Definition => + New_Copy (Result_Definition (Type_Definition (N)))); else Def1 := @@ -4158,9 +4554,10 @@ package body Exp_Ch9 is -- Expand_N_Asynchronous_Select -- ---------------------------------- - -- This procedure assumes that the trigger statement is an entry call. A - -- delay alternative should already have been expanded into an entry call - -- to the appropriate delay object Wait entry. + -- This procedure assumes that the trigger statement is an entry call or + -- a dispatching procedure call. A delay alternative should already have + -- been expanded into an entry call to the appropriate delay object Wait + -- entry. -- If the trigger is a task entry call, the select is implemented with -- a Task_Entry_Call: @@ -4191,19 +4588,19 @@ package body Exp_Ch9 is -- begin -- begin -- Abort_Undefer; - -- abortable-part + -- -- at end -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions. -- end; - -- exception - -- when Abort_Signal => Abort_Undefer; + -- when Abort_Signal => Abort_Undefer; -- end; + -- parm := P.param; -- parm := P.param; -- ... -- if not C then - -- triggered-statements + -- -- end if; -- end; @@ -4250,20 +4647,17 @@ package body Exp_Ch9 is -- Mode => Asynchronous_Call; -- Block => Bnn); -- if Enqueued (Bnn) then - -- + -- -- end if; -- at end -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions. -- end; - -- exception - -- when Abort_Signal => - -- Abort_Undefer; - -- null; + -- when Abort_Signal => Abort_Undefer; -- end; -- if not Cancelled (Bnn) then - -- triggered statements + -- -- end if; -- end; @@ -4286,6 +4680,100 @@ package body Exp_Ch9 is -- ... -- end; + -- Ada 2005 (AI-345): If the trigger is a dispatching call, the select is + -- expanded into: + + -- declare + -- B : Boolean := False; + -- Bnn : Communication_Block; + -- C : Ada.Tags.Prim_Op_Kind; + -- P : Parameters := (Param1 .. ParamN) + -- S : constant Integer := DT_Position (); + -- U : Boolean; + + -- procedure A is + -- begin + -- + -- end A; + + -- procedure T is + -- begin + -- + -- end T; + + -- begin + -- disp_get_prim_op_kind (, S, C); + + -- if C = POK_Protected_Entry then + -- declare + -- procedure _clean is + -- begin + -- if Enqueued (Bnn) then + -- Cancel_Protected_Entry_Call (Bnn); + -- end if; + -- end _clean; + + -- begin + -- begin + -- disp_asynchronous_select + -- (Obj, S, P'address, Bnn, B); + + -- Param1 := P.Param1; + -- ... + -- ParamN := P.ParamN; + + -- if Enqueued (Bnn) then + -- A; + -- end if; + -- at end + -- _clean; + -- end; + -- exception + -- when Abort_Signal => Abort_Undefer; + -- end; + + -- if not Cancelled (Bnn) then + -- T; + -- end if; + + -- elsif C = POK_Task_Entry then + -- declare + -- procedure _clean is + -- begin + -- Cancel_Task_Entry_Call (U); + -- end _clean; + + -- begin + -- Abort_Defer; + + -- disp_asynchronous_select + -- (, S, P'address, Bnn, B); + + -- Param1 := P.Param1; + -- ... + -- ParamN := P.ParamN; + + -- begin + -- begin + -- Abort_Undefer; + -- A; + -- at end + -- _clean; + -- end; + -- exception + -- when Abort_Signal => Abort_Undefer; + -- end; + + -- if not U then + -- T; + -- end if; + -- end; + + -- else + -- ; + -- T; + -- end if; + -- The job is to convert this to the asynchronous form -- If the trigger is a delay statement, it will have been expanded into a @@ -4302,37 +4790,55 @@ package body Exp_Ch9 is procedure Expand_N_Asynchronous_Select (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); - Trig : constant Node_Id := Triggering_Alternative (N); Abrt : constant Node_Id := Abortable_Part (N); - Tstats : constant List_Id := Statements (Trig); Astats : constant List_Id := Statements (Abrt); + Trig : constant Node_Id := Triggering_Alternative (N); + Tstats : constant List_Id := Statements (Trig); - Ecall : Node_Id; + Abortable_Block : Node_Id; + Actuals : List_Id; + Aproc : Entity_Id; + Blk_Ent : Entity_Id; + Blk_Typ : Entity_Id; + Call : Node_Id; + Call_Ent : Entity_Id; + Cancel_Param : Entity_Id; + Cleanup_Block : Node_Id; + Cleanup_Stmts : List_Id; Concval : Node_Id; - Ename : Node_Id; - Index : Node_Id; - Hdle : List_Id; - Decls : List_Id; + Dblock_Ent : Entity_Id; Decl : Node_Id; - Parms : List_Id; - Parm : Node_Id; - Call : Node_Id; - Stmts : List_Id; + Decls : List_Id; + Ecall : Node_Id; + Ename : Node_Id; Enqueue_Call : Node_Id; - Stmt : Node_Id; - B : Entity_Id; - Pdef : Entity_Id; - Dblock_Ent : Entity_Id; + Formals : List_Id; + Hdle : List_Id; + Index : Node_Id; N_Orig : Node_Id; - Abortable_Block : Node_Id; - Cancel_Param : Entity_Id; - Blkent : Entity_Id; + Obj : Entity_Id; + Param : Node_Id; + Params : List_Id; + Pdef : Entity_Id; + ProtE_Stmts : List_Id; + ProtP_Stmts : List_Id; + Stmt : Node_Id; + Stmts : List_Id; Target_Undefer : RE_Id; + TaskE_Stmts : List_Id; + Tproc : Entity_Id; Undefer_Args : List_Id := No_List; + B : Entity_Id; -- Call status flag + Bnn : Entity_Id; -- Communication block + C : Entity_Id; -- Call kind + P : Node_Id; -- Parameter block + S : Entity_Id; -- Primitive operation slot + U : Entity_Id; -- Additional status flag + begin - Blkent := Make_Defining_Identifier (Loc, New_Internal_Name ('A')); - Ecall := Triggering_Statement (Trig); + Blk_Ent := Make_Defining_Identifier (Loc, New_Internal_Name ('A')); + Ecall := Triggering_Statement (Trig); -- The arguments in the call may require dynamic allocation, and the -- call statement may have been transformed into a block. The block @@ -4341,7 +4847,6 @@ package body Exp_Ch9 is if Nkind (Ecall) = N_Block_Statement then Ecall := First (Statements (Handled_Statement_Sequence (Ecall))); - while Nkind (Ecall) /= N_Procedure_Call_Statement and then Nkind (Ecall) /= N_Entry_Call_Statement loop @@ -4349,112 +4854,483 @@ package body Exp_Ch9 is end loop; end if; - -- If a delay was used as a trigger, it will have been expanded - -- into a procedure call. Convert it to the appropriate sequence of - -- statements, similar to what is done for a task entry call. - -- Note that this currently supports only Duration, Real_Time.Time, - -- and Calendar.Time. + -- This is either a dispatching call or a delay statement used as a + -- trigger which was expanded into a procedure call. if Nkind (Ecall) = N_Procedure_Call_Statement then + if Ada_Version >= Ada_05 + and then + (not Present (Original_Node (Ecall)) + or else + Nkind (Original_Node (Ecall)) /= N_Delay_Relative_Statement) + then + Extract_Dispatching_Call (Ecall, Call_Ent, Obj, Actuals, Formals); - -- Add a Delay_Block object to the parameter list of the - -- delay procedure to form the parameter list of the Wait - -- entry call. - - Dblock_Ent := Make_Defining_Identifier (Loc, New_Internal_Name ('D')); + Decls := New_List; + Stmts := New_List; - Pdef := Entity (Name (Ecall)); + -- Call status flag processing, generate: + -- B : Boolean := False; - if Is_RTE (Pdef, RO_CA_Delay_For) then - Enqueue_Call := New_Reference_To (RTE (RE_Enqueue_Duration), Loc); + B := SEU.Build_B (Loc, Decls); - elsif Is_RTE (Pdef, RO_CA_Delay_Until) then - Enqueue_Call := New_Reference_To (RTE (RE_Enqueue_Calendar), Loc); + -- Communication block processing, generate: + -- Bnn : Communication_Block; - else pragma Assert (Is_RTE (Pdef, RO_RT_Delay_Until)); - Enqueue_Call := New_Reference_To (RTE (RE_Enqueue_RT), Loc); - end if; + Bnn := Make_Defining_Identifier (Loc, New_Internal_Name ('B')); - Append_To (Parameter_Associations (Ecall), - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Dblock_Ent, Loc), - Attribute_Name => Name_Unchecked_Access)); + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + Bnn, + Object_Definition => + New_Reference_To (RTE (RE_Communication_Block), Loc))); - -- Create the inner block to protect the abortable part + -- Call kind processing, generate: + -- C : Ada.Tags.Prim_Op_Kind; - Hdle := New_List ( - Make_Exception_Handler (Loc, - Exception_Choices => - New_List (New_Reference_To (Stand.Abort_Signal, Loc)), - Statements => New_List ( - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc))))); + C := SEU.Build_C (Loc, Decls); - Prepend_To (Astats, - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc))); + -- Parameter block processing - Abortable_Block := - Make_Block_Statement (Loc, - Identifier => New_Reference_To (Blkent, Loc), - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => Astats), - Has_Created_Identifier => True, - Is_Asynchronous_Call_Block => True); + Blk_Typ := Build_Parameter_Block + (Loc, Actuals, Formals, Decls); + P := Parameter_Block_Pack + (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts); - -- Append call to if Enqueue (When, DB'Unchecked_Access) then + -- Dispatch table slot processing, generate: + -- S : constant Integer := + -- DT_Position (); - Rewrite (Ecall, - Make_Implicit_If_Statement (N, - Condition => Make_Function_Call (Loc, - Name => Enqueue_Call, - Parameter_Associations => Parameter_Associations (Ecall)), - Then_Statements => - New_List (Make_Block_Statement (Loc, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List ( - Make_Implicit_Label_Declaration (Loc, - Defining_Identifier => Blkent, - Label_Construct => Abortable_Block), - Abortable_Block), - Exception_Handlers => Hdle))))); + S := SEU.Build_S (Loc, Decls, Call_Ent); - Stmts := New_List (Ecall); + -- Additional status flag processing, generate: - -- Construct statement sequence for new block + U := Make_Defining_Identifier (Loc, Name_uU); - Append_To (Stmts, - Make_Implicit_If_Statement (N, - Condition => Make_Function_Call (Loc, - Name => New_Reference_To ( - RTE (RE_Timed_Out), Loc), - Parameter_Associations => New_List ( - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Dblock_Ent, Loc), - Attribute_Name => Name_Unchecked_Access))), - Then_Statements => Tstats)); + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + U, + Object_Definition => + New_Reference_To (Standard_Boolean, Loc))); - -- The result is the new block + -- Generate: + -- procedure A is + -- begin + -- Astmts + -- end A; - Set_Entry_Cancel_Parameter (Blkent, Dblock_Ent); + Aproc := SEU.Build_Wrapping_Procedure (Loc, 'A', Decls, Astats); - Rewrite (N, - Make_Block_Statement (Loc, - Declarations => New_List ( - Make_Object_Declaration (Loc, - Defining_Identifier => Dblock_Ent, - Aliased_Present => True, - Object_Definition => New_Reference_To ( - RTE (RE_Delay_Block), Loc))), + -- Generate: + -- procedure T is + -- begin + -- Tstmts + -- end T; - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, Stmts))); + Tproc := SEU.Build_Wrapping_Procedure (Loc, 'T', Decls, Tstats); - Analyze (N); - return; + -- Generate: + -- _dispatching_get_prim_op_kind (, S, C); + + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + Make_Identifier (Loc, Name_uDisp_Get_Prim_Op_Kind), + Parameter_Associations => + New_List ( + New_Copy_Tree (Obj), + New_Reference_To (S, Loc), + New_Reference_To (C, Loc)))); + + -- Protected entry handling + + -- Generate: + -- Param1 := P.Param1; + -- ... + -- ParamN := P.ParamN; + + Cleanup_Stmts := Parameter_Block_Unpack (Loc, Actuals, Formals); + + -- Generate: + -- _dispatching_asynchronous_select + -- (, S, P'address, Bnn, B); + + Prepend_To (Cleanup_Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + Make_Identifier (Loc, Name_uDisp_Asynchronous_Select), + Parameter_Associations => + New_List ( + New_Copy_Tree (Obj), + New_Reference_To (S, Loc), + P, + New_Reference_To (Bnn, Loc), + New_Reference_To (B, Loc)))); + + -- Generate: + -- if Enqueued (Bnn) then + -- A + -- end if; + + -- where A is the abort statements wrapping procedure + + Append_To (Cleanup_Stmts, + Make_If_Statement (Loc, + Condition => + Make_Function_Call (Loc, + Name => + New_Reference_To (RTE (RE_Enqueued), Loc), + Parameter_Associations => + New_List ( + New_Reference_To (Bnn, Loc))), + + Then_Statements => + New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (Aproc, Loc), + Parameter_Associations => + No_List)))); + + -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions + -- will then generate a _clean for the communication block Bnn. + + -- Generate: + -- declare + -- procedure _clean is + -- begin + -- if Enqueued (Bnn) then + -- Cancel_Protected_Entry_Call (Bnn); + -- end if; + -- end _clean; + -- begin + -- Cleanup_Stmts + -- at end + -- _clean; + -- end; + + Cleanup_Block := + SEU.Build_Cleanup_Block (Loc, Blk_Ent, Cleanup_Stmts, Bnn); + + -- Wrap the cleanup block in an exception handling block. + + -- Generate: + -- begin + -- Cleanup_Block + -- exception + -- when Abort_Signal => Abort_Undefer; + -- end; + + ProtE_Stmts := + New_List ( + SEU.Build_Abort_Block (Loc, Blk_Ent, Cleanup_Block)); + + -- Generate: + -- if not Cancelled (Bnn) then + -- T + -- end if; + + -- there T is the triggering statements wrapping procedure + + Append_To (ProtE_Stmts, + Make_If_Statement (Loc, + Condition => + Make_Op_Not (Loc, + Right_Opnd => + Make_Function_Call (Loc, + Name => + New_Reference_To (RTE (RE_Cancelled), Loc), + Parameter_Associations => + New_List ( + New_Reference_To (Bnn, Loc)))), + + Then_Statements => + New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (Tproc, Loc), + Parameter_Associations => + No_List)))); + + ------------------------------------------------------------------- + -- Task entry handling + + -- Generate: + -- Param1 := P.Param1; + -- ... + -- ParamN := P.ParamN; + + TaskE_Stmts := Parameter_Block_Unpack (Loc, Actuals, Formals); + + -- Generate: + -- _dispatching_asynchronous_select + -- (, S, P'address, Bnn, B); + + Prepend_To (TaskE_Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + Make_Identifier (Loc, Name_uDisp_Asynchronous_Select), + Parameter_Associations => + New_List ( + New_Copy_Tree (Obj), + New_Reference_To (S, Loc), + New_Copy_Tree (P), + New_Reference_To (Bnn, Loc), + New_Reference_To (B, Loc)))); + + -- Generate: + -- Abort_Defer; + + Prepend_To (TaskE_Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Abort_Defer), Loc), + Parameter_Associations => + No_List)); + + -- Generate: + -- Abort_Undefer; + -- A + + -- where A is the abortable statements wrapping procedure + + Cleanup_Stmts := + New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Abort_Undefer), Loc), + Parameter_Associations => + No_List), + + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (Aproc, Loc), + Parameter_Associations => + No_List)); + + -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions + -- will generate a _clean for the additional status flag. + + -- Generate: + -- declare + -- procedure _clean is + -- begin + -- Cancel_Task_Entry_Call (U); + -- end _clean; + -- begin + -- Cleanup_Stmts + -- at end + -- _clean; + -- end; + + Blk_Ent := Make_Defining_Identifier (Loc, New_Internal_Name ('A')); + + Cleanup_Block := + SEU.Build_Cleanup_Block (Loc, Blk_Ent, Cleanup_Stmts, U); + + -- Wrap the cleanup block in an exception handling block + + -- Generate: + -- begin + -- Cleanup_Block + -- exception + -- when Abort_Signal => Abort_Undefer; + -- end; + + Append_To (TaskE_Stmts, + SEU.Build_Abort_Block (Loc, Blk_Ent, Cleanup_Block)); + + -- Generate: + -- if not U then + -- T + -- end if; + + -- where T is the triggering statements wrapping procedure + + Append_To (TaskE_Stmts, + Make_If_Statement (Loc, + Condition => + Make_Op_Not (Loc, + Right_Opnd => + New_Reference_To (U, Loc)), + Then_Statements => + New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (Tproc, Loc), + Parameter_Associations => + No_List)))); + + ------------------------------------------------------------------- + -- Protected procedure handling + + -- Generate: + -- ; + -- T; + + -- where T is the triggering statements wrapping procedure + + ProtP_Stmts := + New_List ( + New_Copy_Tree (Ecall), + + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (Tproc, Loc), + Parameter_Associations => + No_List)); + + -- Generate: + -- if C = POK_Procedure_Entry then + -- ProtE_Stmts + -- elsif C = POK_Task_Entry then + -- TaskE_Stmts + -- else + -- ProtP_Stmts + -- end if; + + Append_To (Stmts, + Make_If_Statement (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => + New_Reference_To (C, Loc), + Right_Opnd => + New_Reference_To (RTE (RE_POK_Protected_Entry), Loc)), + + Then_Statements => + ProtE_Stmts, + + Elsif_Parts => + New_List ( + Make_Elsif_Part (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => + New_Reference_To (C, Loc), + Right_Opnd => + New_Reference_To (RTE (RE_POK_Task_Entry), Loc)), + Then_Statements => + TaskE_Stmts)), + + Else_Statements => + ProtP_Stmts)); + + Rewrite (N, + Make_Block_Statement (Loc, + Declarations => + Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, Stmts))); + + Analyze (N); + return; + + -- Delay triggering statement processing + + else + -- Add a Delay_Block object to the parameter list of the delay + -- procedure to form the parameter list of the Wait entry call. + + Dblock_Ent := + Make_Defining_Identifier (Loc, New_Internal_Name ('D')); + + Pdef := Entity (Name (Ecall)); + + if Is_RTE (Pdef, RO_CA_Delay_For) then + Enqueue_Call := + New_Reference_To (RTE (RE_Enqueue_Duration), Loc); + + elsif Is_RTE (Pdef, RO_CA_Delay_Until) then + Enqueue_Call := + New_Reference_To (RTE (RE_Enqueue_Calendar), Loc); + + else pragma Assert (Is_RTE (Pdef, RO_RT_Delay_Until)); + Enqueue_Call := New_Reference_To (RTE (RE_Enqueue_RT), Loc); + end if; + + Append_To (Parameter_Associations (Ecall), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Dblock_Ent, Loc), + Attribute_Name => Name_Unchecked_Access)); + + -- Create the inner block to protect the abortable part + + Hdle := New_List ( + Make_Exception_Handler (Loc, + Exception_Choices => + New_List (New_Reference_To (Stand.Abort_Signal, Loc)), + Statements => New_List ( + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc))))); + + Prepend_To (Astats, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc))); + + Abortable_Block := + Make_Block_Statement (Loc, + Identifier => New_Reference_To (Blk_Ent, Loc), + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Astats), + Has_Created_Identifier => True, + Is_Asynchronous_Call_Block => True); + + -- Append call to if Enqueue (When, DB'Unchecked_Access) then + + Rewrite (Ecall, + Make_Implicit_If_Statement (N, + Condition => Make_Function_Call (Loc, + Name => Enqueue_Call, + Parameter_Associations => Parameter_Associations (Ecall)), + Then_Statements => + New_List (Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Implicit_Label_Declaration (Loc, + Defining_Identifier => Blk_Ent, + Label_Construct => Abortable_Block), + Abortable_Block), + Exception_Handlers => Hdle))))); + + Stmts := New_List (Ecall); + + -- Construct statement sequence for new block + + Append_To (Stmts, + Make_Implicit_If_Statement (N, + Condition => Make_Function_Call (Loc, + Name => New_Reference_To ( + RTE (RE_Timed_Out), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Dblock_Ent, Loc), + Attribute_Name => Name_Unchecked_Access))), + Then_Statements => Tstats)); + + -- The result is the new block + Set_Entry_Cancel_Parameter (Blk_Ent, Dblock_Ent); + + Rewrite (N, + Make_Block_Statement (Loc, + Declarations => New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Dblock_Ent, + Aliased_Present => True, + Object_Definition => New_Reference_To ( + RTE (RE_Delay_Block), Loc))), + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, Stmts))); + + Analyze (N); + return; + end if; else N_Orig := N; end if; @@ -4471,9 +5347,10 @@ package body Exp_Ch9 is Decl := First (Decls); while Present (Decl) - and then (Nkind (Decl) /= N_Object_Declaration - or else not Is_RTE - (Etype (Object_Definition (Decl)), RE_Communication_Block)) + and then + (Nkind (Decl) /= N_Object_Declaration + or else not Is_RTE (Etype (Object_Definition (Decl)), + RE_Communication_Block)) loop Next (Decl); end loop; @@ -4481,7 +5358,8 @@ package body Exp_Ch9 is pragma Assert (Present (Decl)); Cancel_Param := Defining_Identifier (Decl); - -- Change the mode of the Protected_Entry_Call call. + -- Change the mode of the Protected_Entry_Call call + -- Protected_Entry_Call ( -- Object => po._object'Access, -- E => ; @@ -4491,7 +5369,8 @@ package body Exp_Ch9 is Stmt := First (Stmts); - -- Skip assignments to temporaries created for in-out parameters. + -- Skip assignments to temporaries created for in-out parameters + -- This makes unwarranted assumptions about the shape of the expanded -- tree for the call, and should be cleaned up ??? @@ -4501,19 +5380,21 @@ package body Exp_Ch9 is Call := Stmt; - Parm := First (Parameter_Associations (Call)); - while Present (Parm) - and then not Is_RTE (Etype (Parm), RE_Call_Modes) + Param := First (Parameter_Associations (Call)); + while Present (Param) + and then not Is_RTE (Etype (Param), RE_Call_Modes) loop - Next (Parm); + Next (Param); end loop; - pragma Assert (Present (Parm)); - Rewrite (Parm, New_Reference_To (RTE (RE_Asynchronous_Call), Loc)); - Analyze (Parm); + pragma Assert (Present (Param)); + Rewrite (Param, New_Reference_To (RTE (RE_Asynchronous_Call), Loc)); + Analyze (Param); - -- Append an if statement to execute the abortable part. - -- if Enqueued (Bnn) then + -- Append an if statement to execute the abortable part + + -- Generate: + -- if Enqueued (Bnn) then Append_To (Stmts, Make_Implicit_If_Statement (N, @@ -4526,7 +5407,7 @@ package body Exp_Ch9 is Abortable_Block := Make_Block_Statement (Loc, - Identifier => New_Reference_To (Blkent, Loc), + Identifier => New_Reference_To (Blk_Ent, Loc), Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts), @@ -4552,7 +5433,7 @@ package body Exp_Ch9 is Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List ( Make_Implicit_Label_Declaration (Loc, - Defining_Identifier => Blkent, + Defining_Identifier => Blk_Ent, Label_Construct => Abortable_Block), Abortable_Block), @@ -4640,7 +5521,7 @@ package body Exp_Ch9 is Abortable_Block := Make_Block_Statement (Loc, - Identifier => New_Reference_To (Blkent, Loc), + Identifier => New_Reference_To (Blk_Ent, Loc), Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => Astats), @@ -4653,27 +5534,33 @@ package body Exp_Ch9 is Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List ( Make_Implicit_Label_Declaration (Loc, - Defining_Identifier => Blkent, + Defining_Identifier => Blk_Ent, Label_Construct => Abortable_Block), Abortable_Block), Exception_Handlers => Hdle))); -- Create new call statement - Parms := Parameter_Associations (Call); - Append_To (Parms, New_Reference_To (RTE (RE_Asynchronous_Call), Loc)); - Append_To (Parms, New_Reference_To (B, Loc)); + Params := Parameter_Associations (Call); + + Append_To (Params, + New_Reference_To (RTE (RE_Asynchronous_Call), Loc)); + Append_To (Params, + New_Reference_To (B, Loc)); + Rewrite (Call, Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (RTE (RE_Task_Entry_Call), Loc), - Parameter_Associations => Parms)); + Name => + New_Reference_To (RTE (RE_Task_Entry_Call), Loc), + Parameter_Associations => Params)); -- Construct statement sequence for new block Append_To (Stmts, Make_Implicit_If_Statement (N, - Condition => Make_Op_Not (Loc, - New_Reference_To (Cancel_Param, Loc)), + Condition => + Make_Op_Not (Loc, + New_Reference_To (Cancel_Param, Loc)), Then_Statements => Tstats)); -- Protected the call against abort @@ -4684,7 +5571,7 @@ package body Exp_Ch9 is Parameter_Associations => Empty_List)); end if; - Set_Entry_Cancel_Parameter (Blkent, Cancel_Param); + Set_Entry_Cancel_Parameter (Blk_Ent, Cancel_Param); -- The result is the new block @@ -4786,21 +5673,199 @@ package body Exp_Ch9 is -- ... -- end; + -- Ada 2005 (AI-345): A dispatching conditional entry call is converted + -- into: + + -- declare + -- B : Boolean := False; + -- C : Ada.Tags.Prim_Op_Kind; + -- P : Parameters := (Param1 .. ParamN); + -- S : constant Integer := DT_Position (); + + -- begin + -- disp_conditional_select (, S, P'address, C, B); + + -- if C = POK_Protected_Entry + -- or else C = POK_Task_Entry + -- then + -- Param1 := P.Param1; + -- ... + -- ParamN := P.ParamN; + -- end if; + + -- if B then + -- if C = POK_Procedure + -- or else C = POK_Protected_Procedure + -- or else C = POK_Task_Procedure + -- then + -- (, Param1 .. ParamN); + -- end if; + -- + -- else + -- + -- end if; + -- end; + procedure Expand_N_Conditional_Entry_Call (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Alt : constant Node_Id := Entry_Call_Alternative (N); Blk : Node_Id := Entry_Call_Statement (Alt); Transient_Blk : Node_Id; - Parms : List_Id; - Parm : Node_Id; - Call : Node_Id; - Stmts : List_Id; - B : Entity_Id; - Decl : Node_Id; - Stmt : Node_Id; + Actuals : List_Id; + Blk_Typ : Entity_Id; + Call : Node_Id; + Call_Ent : Entity_Id; + Decl : Node_Id; + Decls : List_Id; + Formals : List_Id; + N_Stats : List_Id; + Obj : Entity_Id; + Param : Node_Id; + Params : List_Id; + Stmt : Node_Id; + Stmts : List_Id; + + B : Entity_Id; -- Call status flag + C : Entity_Id; -- Call kind + P : Node_Id; -- Parameter block + S : Entity_Id; -- Primitive operation slot begin + if Ada_Version >= Ada_05 + and then Nkind (Blk) = N_Procedure_Call_Statement + then + Extract_Dispatching_Call (Blk, Call_Ent, Obj, Actuals, Formals); + + Decls := New_List; + Stmts := New_List; + + -- Call status flag processing, generate: + -- B : Boolean := False; + + B := SEU.Build_B (Loc, Decls); + + -- Call kind processing, generate: + -- C : Ada.Tags.Prim_Op_Kind; + + C := SEU.Build_C (Loc, Decls); + + -- Parameter block processing + + Blk_Typ := Build_Parameter_Block (Loc, Actuals, Formals, Decls); + P := Parameter_Block_Pack (Loc, Blk_Typ, Actuals, Formals, + Decls, Stmts); + + -- Dispatch table slot processing, generate: + -- S : constant Integer := + -- DT_Position (); + + S := SEU.Build_S (Loc, Decls, Call_Ent); + + -- Generate: + -- _dispatching_conditional_select (, S, P'address, C, B); + + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + Make_Identifier (Loc, Name_uDisp_Conditional_Select), + Parameter_Associations => + New_List ( + New_Copy_Tree (Obj), + New_Reference_To (S, Loc), + P, + New_Reference_To (C, Loc), + New_Reference_To (B, Loc)))); + + -- Generate: + -- if C = POK_Protected_Entry + -- or else C = POK_Task_Entry + -- then + -- Param1 := P.Param1; + -- ... + -- ParamN := P.ParamN; + -- end if; + + Append_To (Stmts, + Make_If_Statement (Loc, + + Condition => + Make_Or_Else (Loc, + Left_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + New_Reference_To (C, Loc), + Right_Opnd => + New_Reference_To (RTE (RE_POK_Protected_Entry), Loc)), + Right_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + New_Reference_To (C, Loc), + Right_Opnd => + New_Reference_To (RTE (RE_POK_Task_Entry), Loc))), + + Then_Statements => + Parameter_Block_Unpack (Loc, Actuals, Formals))); + + -- Generate: + -- if B then + -- if C = POK_Procedure + -- or else C = POK_Protected_Procedure + -- or else C = POK_Task_Procedure + -- then + -- + -- end if; + -- + -- else + -- + -- end if; + + N_Stats := New_Copy_List (Statements (Alt)); + + Prepend_To (N_Stats, + Make_If_Statement (Loc, + Condition => + Make_Or_Else (Loc, + Left_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + New_Reference_To (C, Loc), + Right_Opnd => + New_Reference_To (RTE (RE_POK_Procedure), Loc)), + + Right_Opnd => + Make_Or_Else (Loc, + Left_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + New_Reference_To (C, Loc), + Right_Opnd => + New_Reference_To (RTE ( + RE_POK_Protected_Procedure), Loc)), + + Right_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + New_Reference_To (C, Loc), + Right_Opnd => + New_Reference_To (RTE ( + RE_POK_Task_Procedure), Loc)))), + + Then_Statements => + New_List (Blk))); + + Append_To (Stmts, + Make_If_Statement (Loc, + Condition => New_Reference_To (B, Loc), + Then_Statements => N_Stats, + Else_Statements => Else_Statements (N))); + + Rewrite (N, + Make_Block_Statement (Loc, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, Stmts))); + -- As described above, The entry alternative is transformed into a -- block that contains the gnulli call, and possibly assignment -- statements for in-out parameters. The gnulli call may itself be @@ -4808,110 +5873,108 @@ package body Exp_Ch9 is -- require it. We need to retrieve the call to complete its parameter -- list. - Transient_Blk := - First_Real_Statement (Handled_Statement_Sequence (Blk)); - - if Present (Transient_Blk) - and then - Nkind (Transient_Blk) = N_Block_Statement - then - Blk := Transient_Blk; - end if; - - Stmts := Statements (Handled_Statement_Sequence (Blk)); + else + Transient_Blk := + First_Real_Statement (Handled_Statement_Sequence (Blk)); - Stmt := First (Stmts); + if Present (Transient_Blk) + and then Nkind (Transient_Blk) = N_Block_Statement + then + Blk := Transient_Blk; + end if; - while Nkind (Stmt) /= N_Procedure_Call_Statement loop - Next (Stmt); - end loop; + Stmts := Statements (Handled_Statement_Sequence (Blk)); + Stmt := First (Stmts); + while Nkind (Stmt) /= N_Procedure_Call_Statement loop + Next (Stmt); + end loop; - Call := Stmt; + Call := Stmt; + Params := Parameter_Associations (Call); - Parms := Parameter_Associations (Call); + if Is_RTE (Entity (Name (Call)), RE_Protected_Entry_Call) then - if Is_RTE (Entity (Name (Call)), RE_Protected_Entry_Call) then + -- Substitute Conditional_Entry_Call for Simple_Call parameter - -- Substitute Conditional_Entry_Call for Simple_Call - -- parameter. + Param := First (Params); + while Present (Param) + and then not Is_RTE (Etype (Param), RE_Call_Modes) + loop + Next (Param); + end loop; - Parm := First (Parms); - while Present (Parm) - and then not Is_RTE (Etype (Parm), RE_Call_Modes) - loop - Next (Parm); - end loop; + pragma Assert (Present (Param)); + Rewrite (Param, New_Reference_To (RTE (RE_Conditional_Call), Loc)); - pragma Assert (Present (Parm)); - Rewrite (Parm, New_Reference_To (RTE (RE_Conditional_Call), Loc)); + Analyze (Param); - Analyze (Parm); + -- Find the Communication_Block parameter for the call to the + -- Cancelled function. - -- Find the Communication_Block parameter for the call - -- to the Cancelled function. + Decl := First (Declarations (Blk)); + while Present (Decl) + and then not Is_RTE (Etype (Object_Definition (Decl)), + RE_Communication_Block) + loop + Next (Decl); + end loop; - Decl := First (Declarations (Blk)); - while Present (Decl) - and then not - Is_RTE (Etype (Object_Definition (Decl)), RE_Communication_Block) - loop - Next (Decl); - end loop; + -- Add an if statement to execute the else part if the call + -- does not succeed (as indicated by the Cancelled predicate). - -- Add an if statement to execute the else part if the call - -- does not succeed (as indicated by the Cancelled predicate). + Append_To (Stmts, + Make_Implicit_If_Statement (N, + Condition => Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Cancelled), Loc), + Parameter_Associations => New_List ( + New_Reference_To (Defining_Identifier (Decl), Loc))), + Then_Statements => Else_Statements (N), + Else_Statements => Statements (Alt))); - Append_To (Stmts, - Make_Implicit_If_Statement (N, - Condition => Make_Function_Call (Loc, - Name => New_Reference_To (RTE (RE_Cancelled), Loc), - Parameter_Associations => New_List ( - New_Reference_To (Defining_Identifier (Decl), Loc))), - Then_Statements => Else_Statements (N), - Else_Statements => Statements (Alt))); + else + B := Make_Defining_Identifier (Loc, Name_uB); - else - B := Make_Defining_Identifier (Loc, Name_uB); + -- Insert declaration of B in declarations of existing block - -- Insert declaration of B in declarations of existing block + if No (Declarations (Blk)) then + Set_Declarations (Blk, New_List); + end if; - if No (Declarations (Blk)) then - Set_Declarations (Blk, New_List); - end if; + Prepend_To (Declarations (Blk), + Make_Object_Declaration (Loc, + Defining_Identifier => B, + Object_Definition => + New_Reference_To (Standard_Boolean, Loc))); - Prepend_To (Declarations (Blk), - Make_Object_Declaration (Loc, - Defining_Identifier => B, - Object_Definition => New_Reference_To (Standard_Boolean, Loc))); + -- Create new call statement - -- Create new call statement + Append_To (Params, + New_Reference_To (RTE (RE_Conditional_Call), Loc)); + Append_To (Params, New_Reference_To (B, Loc)); - Append_To (Parms, New_Reference_To (RTE (RE_Conditional_Call), Loc)); - Append_To (Parms, New_Reference_To (B, Loc)); + Rewrite (Call, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Task_Entry_Call), Loc), + Parameter_Associations => Params)); - Rewrite (Call, - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (RTE (RE_Task_Entry_Call), Loc), - Parameter_Associations => Parms)); + -- Construct statement sequence for new block - -- Construct statement sequence for new block + Append_To (Stmts, + Make_Implicit_If_Statement (N, + Condition => New_Reference_To (B, Loc), + Then_Statements => Statements (Alt), + Else_Statements => Else_Statements (N))); + end if; - Append_To (Stmts, - Make_Implicit_If_Statement (N, - Condition => New_Reference_To (B, Loc), - Then_Statements => Statements (Alt), - Else_Statements => Else_Statements (N))); + -- The result is the new block + Rewrite (N, + Make_Block_Statement (Loc, + Declarations => Declarations (Blk), + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, Stmts))); end if; - -- The result is the new block - - Rewrite (N, - Make_Block_Statement (Loc, - Declarations => Declarations (Blk), - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, Stmts))); - Analyze (N); end Expand_N_Conditional_Entry_Call; @@ -4925,7 +5988,6 @@ package body Exp_Ch9 is procedure Expand_N_Delay_Relative_Statement (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); - begin Rewrite (N, Make_Procedure_Call_Statement (Loc, @@ -5193,7 +6255,7 @@ package body Exp_Ch9 is -- -- end pprocN; - -- procedure pproc (_object : in out poV;...) is + -- procedure pprocP (_object : in out poV;...) is -- procedure _clean is -- Pn : Boolean; -- begin @@ -5217,7 +6279,7 @@ package body Exp_Ch9 is -- -- end pfuncN; - -- function pfunc (_object : poV) return Return_Type is + -- function pfuncP (_object : poV) return Return_Type is -- procedure _clean is -- begin -- Unlock (_object._object'Access); @@ -5264,10 +6326,97 @@ package body Exp_Ch9 is Op_Decl : Node_Id; Op_Body : Node_Id; Op_Id : Entity_Id; + Disp_Op_Body : Node_Id; New_Op_Body : Node_Id; Current_Node : Node_Id; Num_Entries : Natural := 0; + function Build_Dispatching_Subprogram_Body + (N : Node_Id; + Pid : Node_Id; + Prot_Bod : Node_Id) return Node_Id; + -- Build a dispatching version of the protected subprogram body. The + -- newly generated subprogram contains a call to the original protected + -- body. The following code is generated: + -- + -- function (Param1 .. ParamN) return + -- is + -- begin + -- return P (Param1 .. ParamN); + -- end ; + -- + -- or + -- + -- procedure (Param1 .. ParamN) is + -- begin + -- P (Param1 .. ParamN); + -- end + + --------------------------------------- + -- Build_Dispatching_Subprogram_Body -- + --------------------------------------- + + function Build_Dispatching_Subprogram_Body + (N : Node_Id; + Pid : Node_Id; + Prot_Bod : Node_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (N); + Actuals : List_Id; + Formal : Node_Id; + Spec : Node_Id; + Stmts : List_Id; + + begin + -- Generate a specification without a letter suffix in order to + -- override an interface function or procedure. + + Spec := + Build_Protected_Sub_Specification (N, Pid, Dispatching_Mode); + + -- The formal parameters become the actuals of the protected + -- function or procedure call. + + Actuals := New_List; + Formal := First (Parameter_Specifications (Spec)); + + while Present (Formal) loop + Append_To (Actuals, + Make_Identifier (Loc, Chars (Defining_Identifier (Formal)))); + + Next (Formal); + end loop; + + if Nkind (Spec) = N_Procedure_Specification then + Stmts := + New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (Corresponding_Spec (Prot_Bod), Loc), + Parameter_Associations => Actuals)); + else + pragma Assert (Nkind (Spec) = N_Function_Specification); + + Stmts := + New_List ( + Make_Return_Statement (Loc, + Expression => + Make_Function_Call (Loc, + Name => + New_Reference_To (Corresponding_Spec (Prot_Bod), Loc), + Parameter_Associations => Actuals))); + end if; + + return + Make_Subprogram_Body (Loc, + Declarations => Empty_List, + Specification => Spec, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, Stmts)); + end Build_Dispatching_Subprogram_Body; + + -- Start of processing for Expand_N_Protected_Body + begin if No_Run_Time_Mode then Error_Msg_CRT ("protected body", N); @@ -5340,6 +6489,26 @@ package body Exp_Ch9 is Insert_After (Current_Node, New_Op_Body); Analyze (New_Op_Body); + + Current_Node := New_Op_Body; + + -- Generate an overriding primitive operation body for + -- this subprogram if the protected type implements + -- an inerface. + + if Ada_Version >= Ada_05 + and then Present (Abstract_Interfaces ( + Corresponding_Record_Type (Pid))) + then + Disp_Op_Body := + Build_Dispatching_Subprogram_Body ( + Op_Body, Pid, New_Op_Body); + + Insert_After (Current_Node, Disp_Op_Body); + Analyze (Disp_Op_Body); + + Current_Node := Disp_Op_Body; + end if; end if; end if; end if; @@ -5723,7 +6892,13 @@ package body Exp_Ch9 is Sloc => Loc, Constraints => New_List (Entry_Count_Expr))); - elsif Has_Entries (Prottyp) then + -- The type has explicit entries or generated primitive entry + -- wrappers. + + elsif Has_Entries (Prottyp) + or else (Ada_Version >= Ada_05 + and then Present (Interface_List (N))) + then if Abort_Allowed or else Restriction_Active (No_Entry_Queue) = False or else Number_Entries (Prottyp) > 1 @@ -5795,7 +6970,7 @@ package body Exp_Ch9 is Make_Subprogram_Declaration (Loc, Specification => Build_Protected_Sub_Specification - (Priv, Prottyp, Unprotected => True)); + (Priv, Prottyp, Unprotected_Mode)); Insert_After (Current_Node, Sub); Analyze (Sub); @@ -5805,6 +6980,7 @@ package body Exp_Ch9 is Defining_Unit_Name (Specification (Sub))); Current_Node := Sub; + if Is_Interrupt_Handler (Defining_Unit_Name (Specification (Priv))) then @@ -5812,7 +6988,7 @@ package body Exp_Ch9 is Make_Subprogram_Declaration (Loc, Specification => Build_Protected_Sub_Specification - (Priv, Prottyp, Unprotected => False)); + (Priv, Prottyp, Protected_Mode)); Insert_After (Current_Node, Sub); Analyze (Sub); @@ -5939,7 +7115,7 @@ package body Exp_Ch9 is Make_Subprogram_Declaration (Loc, Specification => Build_Protected_Sub_Specification - (Comp, Prottyp, Unprotected => True)); + (Comp, Prottyp, Unprotected_Mode)); Insert_After (Current_Node, Sub); Analyze (Sub); @@ -5957,12 +7133,33 @@ package body Exp_Ch9 is Make_Subprogram_Declaration (Loc, Specification => Build_Protected_Sub_Specification - (Comp, Prottyp, Unprotected => False)); + (Comp, Prottyp, Protected_Mode)); Insert_After (Current_Node, Sub); Analyze (Sub); + Current_Node := Sub; + -- Generate an overriding primitive operation specification for + -- this subprogram if the protected type implements an inerface. + + if Ada_Version >= Ada_05 + and then + Present (Abstract_Interfaces + (Corresponding_Record_Type (Prottyp))) + then + Sub := + Make_Subprogram_Declaration (Loc, + Specification => + Build_Protected_Sub_Specification + (Comp, Prottyp, Dispatching_Mode)); + + Insert_After (Current_Node, Sub); + Analyze (Sub); + + Current_Node := Sub; + end if; + -- If a pragma Interrupt_Handler applies, build and add -- a call to Register_Interrupt_Handler to the freezing actions -- of the protected version (Current_Node) of the subprogram: @@ -5971,7 +7168,7 @@ package body Exp_Ch9 is if not Restricted_Profile and then Is_Interrupt_Handler - (Defining_Unit_Name (Specification (Comp))) + (Defining_Unit_Name (Specification (Comp))) then Register_Handler; end if; @@ -6042,7 +7239,6 @@ package body Exp_Ch9 is if Present (Private_Declarations (Pdef)) then Comp := First (Private_Declarations (Pdef)); - while Present (Comp) loop if Nkind (Comp) = N_Entry_Declaration then E_Count := E_Count + 1; @@ -8125,11 +9321,11 @@ package body Exp_Ch9 is -- 1) When T.E is a task entry_call; -- declare - -- B : Boolean; - -- X : Task_Entry_Index := ; + -- B : Boolean; + -- X : Task_Entry_Index := ; -- DX : Duration := To_Duration (D); - -- M : Delay_Mode := ; - -- P : parms := (parm, parm, parm); + -- M : Delay_Mode := ; + -- P : parms := (parm, parm, parm); -- begin -- Timed_Protected_Entry_Call (, X, P'Address, @@ -8147,7 +9343,7 @@ package body Exp_Ch9 is -- B : Boolean; -- X : Protected_Entry_Index := ; -- DX : Duration := To_Duration (D); - -- M : Delay_Mode := ; + -- M : Delay_Mode := ; -- P : parms := (parm, parm, parm); -- begin @@ -8160,6 +9356,40 @@ package body Exp_Ch9 is -- end if; -- end; + -- 3) Ada 2005 (AI-345): When T.E is a dispatching procedure call; + + -- declare + -- B : Boolean := False; + -- C : Ada.Tags.Prim_Op_Kind; + -- DX : Duration := To_Duration (D) + -- M : Integer :=...; + -- P : Parameters := (Param1 .. ParamN); + -- S : constant Iteger := DT_Position (); + + -- begin + -- disp_timed_select (, S, P'Address, DX, M, C, B); + + -- if C = POK_Protected_Entry + -- or else C = POK_Task_Entry + -- then + -- Param1 := P.Param1; + -- ... + -- ParamN := P.ParamN; + -- end if; + + -- if B then + -- if C = POK_Procedure + -- or else C = POK_Protected_Procedure + -- or else C = POK_Task_Procedure + -- then + -- T.E; + -- end if; + -- S1; + -- else + -- S2; + -- end if; + -- end; + procedure Expand_N_Timed_Entry_Call (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); @@ -8172,25 +9402,32 @@ package body Exp_Ch9 is D_Stats : constant List_Id := Statements (Delay_Alternative (N)); - Stmts : List_Id; - Stmt : Node_Id; - Parms : List_Id; - Parm : Node_Id; - - Concval : Node_Id; - Ename : Node_Id; - Index : Node_Id; - - Decls : List_Id; - Disc : Node_Id; - Conv : Node_Id; - B : Entity_Id; - D : Entity_Id; - Dtyp : Entity_Id; - M : Entity_Id; - - Call : Node_Id; - Dummy : Node_Id; + Actuals : List_Id; + Blk_Typ : Entity_Id; + Call : Node_Id; + Call_Ent : Entity_Id; + Concval : Node_Id; + D_Conv : Node_Id; + D_Disc : Node_Id; + D_Type : Entity_Id; + Decls : List_Id; + Dummy : Node_Id; + Ename : Node_Id; + Formals : List_Id; + Index : Node_Id; + N_Stats : List_Id; + Obj : Entity_Id; + Param : Node_Id; + Params : List_Id; + Stmt : Node_Id; + Stmts : List_Id; + + B : Entity_Id; -- Call status flag + C : Entity_Id; -- Call kind + D : Entity_Id; -- Delay + M : Entity_Id; -- Delay mode + P : Node_Id; -- Parameter block + S : Entity_Id; -- Primitive operation slot begin -- The arguments in the call may require dynamic allocation, and the @@ -8200,7 +9437,6 @@ package body Exp_Ch9 is if Nkind (E_Call) = N_Block_Statement then E_Call := First (Statements (Handled_Statement_Sequence (E_Call))); - while Nkind (E_Call) /= N_Procedure_Call_Statement and then Nkind (E_Call) /= N_Entry_Call_Statement loop @@ -8208,170 +9444,350 @@ package body Exp_Ch9 is end loop; end if; - -- Build an entry call using Simple_Entry_Call. We will use this as the - -- base for creating appropriate calls. + if Ada_Version >= Ada_05 + and then Nkind (E_Call) = N_Procedure_Call_Statement + then + Extract_Dispatching_Call (E_Call, Call_Ent, Obj, Actuals, Formals); + + Decls := New_List; + Stmts := New_List; - Extract_Entry (E_Call, Concval, Ename, Index); - Build_Simple_Entry_Call (E_Call, Concval, Ename, Index); + else + -- Build an entry call using Simple_Entry_Call - Stmts := Statements (Handled_Statement_Sequence (E_Call)); - Decls := Declarations (E_Call); + Extract_Entry (E_Call, Concval, Ename, Index); + Build_Simple_Entry_Call (E_Call, Concval, Ename, Index); - if No (Decls) then - Decls := New_List; + Decls := Declarations (E_Call); + Stmts := Statements (Handled_Statement_Sequence (E_Call)); + + if No (Decls) then + Decls := New_List; + end if; end if; - Dtyp := Base_Type (Etype (Expression (D_Stat))); + -- Call status flag processing + + if Ada_Version >= Ada_05 + and then Nkind (E_Call) = N_Procedure_Call_Statement + then + -- Generate: + -- B : Boolean := False; + + B := SEU.Build_B (Loc, Decls); + + else + -- Generate: + -- B : Boolean; + + B := Make_Defining_Identifier (Loc, Name_uB); + + Prepend_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + B, + Object_Definition => + New_Reference_To (Standard_Boolean, Loc))); + end if; + + -- Call kind processing + + if Ada_Version >= Ada_05 + and then Nkind (E_Call) = N_Procedure_Call_Statement + then + -- Generate: + -- C : Ada.Tags.Prim_Op_Kind; + + C := SEU.Build_C (Loc, Decls); + end if; + + -- Duration and mode processing + + D_Type := Base_Type (Etype (Expression (D_Stat))); -- Use the type of the delay expression (Calendar or Real_Time) -- to generate the appropriate conversion. if Nkind (D_Stat) = N_Delay_Relative_Statement then - Disc := Make_Integer_Literal (Loc, 0); - Conv := Relocate_Node (Expression (D_Stat)); + D_Disc := Make_Integer_Literal (Loc, 0); + D_Conv := Relocate_Node (Expression (D_Stat)); - elsif Is_RTE (Dtyp, RO_CA_Time) then - Disc := Make_Integer_Literal (Loc, 1); - Conv := Make_Function_Call (Loc, + elsif Is_RTE (D_Type, RO_CA_Time) then + D_Disc := Make_Integer_Literal (Loc, 1); + D_Conv := Make_Function_Call (Loc, New_Reference_To (RTE (RO_CA_To_Duration), Loc), New_List (New_Copy (Expression (D_Stat)))); - else pragma Assert (Is_RTE (Dtyp, RO_RT_Time)); - Disc := Make_Integer_Literal (Loc, 2); - Conv := Make_Function_Call (Loc, + else pragma Assert (Is_RTE (D_Type, RO_RT_Time)); + D_Disc := Make_Integer_Literal (Loc, 2); + D_Conv := Make_Function_Call (Loc, New_Reference_To (RTE (RO_RT_To_Duration), Loc), New_List (New_Copy (Expression (D_Stat)))); end if; - -- Create Duration and Delay_Mode objects for passing a delay value - D := Make_Defining_Identifier (Loc, New_Internal_Name ('D')); - M := Make_Defining_Identifier (Loc, New_Internal_Name ('M')); - Append_To (Decls, - Make_Object_Declaration (Loc, - Defining_Identifier => D, - Object_Definition => New_Reference_To (Standard_Duration, Loc))); + -- Generate: + -- D : Duration; Append_To (Decls, Make_Object_Declaration (Loc, - Defining_Identifier => M, - Object_Definition => New_Reference_To (Standard_Integer, Loc), - Expression => Disc)); + Defining_Identifier => + D, + Object_Definition => + New_Reference_To (Standard_Duration, Loc))); - B := Make_Defining_Identifier (Loc, Name_uB); + M := Make_Defining_Identifier (Loc, New_Internal_Name ('M')); - -- Create a boolean object used for a return parameter + -- Generate: + -- M : Integer := (0 | 1 | 2); - Prepend_To (Decls, + Append_To (Decls, Make_Object_Declaration (Loc, - Defining_Identifier => B, - Object_Definition => New_Reference_To (Standard_Boolean, Loc))); - - Stmt := First (Stmts); - - -- Skip assignments to temporaries created for in-out parameters. - -- This makes unwarranted assumptions about the shape of the expanded - -- tree for the call, and should be cleaned up ??? - - while Nkind (Stmt) /= N_Procedure_Call_Statement loop - Next (Stmt); - end loop; + Defining_Identifier => + M, + Object_Definition => + New_Reference_To (Standard_Integer, Loc), + Expression => + D_Disc)); -- Do the assignement at this stage only because the evaluation of the -- expression must not occur before (see ACVC C97302A). - Insert_Before (Stmt, + Append_To (Stmts, Make_Assignment_Statement (Loc, - Name => New_Reference_To (D, Loc), - Expression => Conv)); + Name => + New_Reference_To (D, Loc), + Expression => + D_Conv)); - Call := Stmt; + -- Parameter block processing - Parms := Parameter_Associations (Call); + -- Manually create the parameter block for dispatching calls. In the + -- case of entries, the block has already been created during the call + -- to Build_Simple_Entry_Call. - -- For a protected type, we build a Timed_Protected_Entry_Call + if Ada_Version >= Ada_05 + and then Nkind (E_Call) = N_Procedure_Call_Statement + then + Blk_Typ := Build_Parameter_Block (Loc, Actuals, Formals, Decls); + P := Parameter_Block_Pack (Loc, Blk_Typ, Actuals, Formals, + Decls, Stmts); - if Is_Protected_Type (Etype (Concval)) then + -- Dispatch table slot processing, generate: + -- S : constant Integer := + -- DT_Prosition () - -- Create a new call statement + S := SEU.Build_S (Loc, Decls, Call_Ent); - Parm := First (Parms); + -- Generate: + -- _dispatching_timed_select (Obj, S, P'address, D, M, C, B); - while Present (Parm) - and then not Is_RTE (Etype (Parm), RE_Call_Modes) - loop - Next (Parm); - end loop; + -- where Obj is the controlling formal parameter, S is the dispatch + -- table slot number of the dispatching operation, P is the wrapped + -- parameter block, D is the duration, M is the duration mode, C is + -- the call kind and B is the call status. - Dummy := Remove_Next (Next (Parm)); + Params := New_List; - -- Remove garbage is following the Cancel_Param if present + Append_To (Params, New_Copy_Tree (Obj)); + Append_To (Params, New_Reference_To (S, Loc)); + Append_To (Params, P); + Append_To (Params, New_Reference_To (D, Loc)); + Append_To (Params, New_Reference_To (M, Loc)); + Append_To (Params, New_Reference_To (C, Loc)); + Append_To (Params, New_Reference_To (B, Loc)); - Dummy := Next (Parm); + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + Make_Identifier (Loc, Name_uDisp_Timed_Select), + Parameter_Associations => + Params)); + + -- Generate: + -- if C = POK_Protected_Entry + -- or else C = POK_Task_Entry + -- then + -- Param1 := P.Param1; + -- ... + -- ParamN := P.ParamN; + -- end if; - -- Remove the mode of the Protected_Entry_Call call, then remove the - -- Communication_Block of the Protected_Entry_Call call, and finally - -- add Duration and a Delay_Mode parameter + Append_To (Stmts, + Make_If_Statement (Loc, + + Condition => + Make_Or_Else (Loc, + Left_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + New_Reference_To (C, Loc), + Right_Opnd => + New_Reference_To (RTE (RE_POK_Protected_Entry), Loc)), + Right_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + New_Reference_To (C, Loc), + Right_Opnd => + New_Reference_To (RTE (RE_POK_Task_Entry), Loc))), - pragma Assert (Present (Parm)); - Rewrite (Parm, New_Reference_To (D, Loc)); + Then_Statements => + Parameter_Block_Unpack (Loc, Actuals, Formals))); + + -- Generate: + -- if B then + -- if C = POK_Procedure + -- or else C = POK_Protected_Procedure + -- or else C = POK_Task_Procedure + -- then + -- + -- end if; + -- + -- else + -- + -- end if; - Rewrite (Dummy, New_Reference_To (M, Loc)); + N_Stats := New_Copy_List (E_Stats); + + Prepend_To (N_Stats, + Make_If_Statement (Loc, + + Condition => + Make_Or_Else (Loc, + Left_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + New_Reference_To (C, Loc), + Right_Opnd => + New_Reference_To (RTE (RE_POK_Procedure), Loc)), + Right_Opnd => + Make_Or_Else (Loc, + Left_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + New_Reference_To (C, Loc), + Right_Opnd => + New_Reference_To (RTE ( + RE_POK_Protected_Procedure), Loc)), + Right_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + New_Reference_To (C, Loc), + Right_Opnd => + New_Reference_To (RTE ( + RE_POK_Task_Procedure), Loc)))), - -- Add a Boolean flag for successful entry call + Then_Statements => + New_List (E_Call))); - Append_To (Parms, New_Reference_To (B, Loc)); + Append_To (Stmts, + Make_If_Statement (Loc, + Condition => New_Reference_To (B, Loc), + Then_Statements => N_Stats, + Else_Statements => D_Stats)); + else + -- Skip assignments to temporaries created for in-out parameters. + -- This makes unwarranted assumptions about the shape of the expanded + -- tree for the call, and should be cleaned up ??? - if Abort_Allowed - or else Restriction_Active (No_Entry_Queue) = False - or else Number_Entries (Etype (Concval)) > 1 - then - Rewrite (Call, - Make_Procedure_Call_Statement (Loc, - Name => - New_Reference_To (RTE (RE_Timed_Protected_Entry_Call), Loc), - Parameter_Associations => Parms)); + Stmt := First (Stmts); + while Nkind (Stmt) /= N_Procedure_Call_Statement loop + Next (Stmt); + end loop; - else - Parm := First (Parms); + -- Do the assignement at this stage only because the evaluation + -- of the expression must not occur before (see ACVC C97302A). - while Present (Parm) - and then not Is_RTE (Etype (Parm), RE_Protected_Entry_Index) + Insert_Before (Stmt, + Make_Assignment_Statement (Loc, + Name => New_Reference_To (D, Loc), + Expression => D_Conv)); + + Call := Stmt; + Params := Parameter_Associations (Call); + + -- For a protected type, we build a Timed_Protected_Entry_Call + + if Is_Protected_Type (Etype (Concval)) then + + -- Create a new call statement + + Param := First (Params); + while Present (Param) + and then not Is_RTE (Etype (Param), RE_Call_Modes) loop - Next (Parm); + Next (Param); end loop; - Remove (Parm); + Dummy := Remove_Next (Next (Param)); - Rewrite (Call, - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To ( - RTE (RE_Timed_Protected_Single_Entry_Call), Loc), - Parameter_Associations => Parms)); - end if; + -- Remove garbage is following the Cancel_Param if present - -- For the task case, build a Timed_Task_Entry_Call + Dummy := Next (Param); - else - -- Create a new call statement + -- Remove the mode of the Protected_Entry_Call call, then remove + -- the Communication_Block of the Protected_Entry_Call call, and + -- finally add Duration and a Delay_Mode parameter - Append_To (Parms, New_Reference_To (D, Loc)); - Append_To (Parms, New_Reference_To (M, Loc)); - Append_To (Parms, New_Reference_To (B, Loc)); + pragma Assert (Present (Param)); + Rewrite (Param, New_Reference_To (D, Loc)); - Rewrite (Call, - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (RTE (RE_Timed_Task_Entry_Call), Loc), - Parameter_Associations => Parms)); + Rewrite (Dummy, New_Reference_To (M, Loc)); - end if; + -- Add a Boolean flag for successful entry call - Append_To (Stmts, - Make_Implicit_If_Statement (N, - Condition => New_Reference_To (B, Loc), - Then_Statements => E_Stats, - Else_Statements => D_Stats)); + Append_To (Params, New_Reference_To (B, Loc)); + + if Abort_Allowed + or else Restriction_Active (No_Entry_Queue) = False + or else Number_Entries (Etype (Concval)) > 1 + then + Rewrite (Call, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE ( + RE_Timed_Protected_Entry_Call), Loc), + Parameter_Associations => Params)); + else + Param := First (Params); + while Present (Param) + and then not Is_RTE (Etype (Param), RE_Protected_Entry_Index) + loop + Next (Param); + end loop; + + Remove (Param); + + Rewrite (Call, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To ( + RTE (RE_Timed_Protected_Single_Entry_Call), Loc), + Parameter_Associations => Params)); + end if; + + -- For the task case, build a Timed_Task_Entry_Call + + else + -- Create a new call statement + + Append_To (Params, New_Reference_To (D, Loc)); + Append_To (Params, New_Reference_To (M, Loc)); + Append_To (Params, New_Reference_To (B, Loc)); + + Rewrite (Call, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Timed_Task_Entry_Call), Loc), + Parameter_Associations => Params)); + end if; + + Append_To (Stmts, + Make_Implicit_If_Statement (N, + Condition => New_Reference_To (B, Loc), + Then_Statements => E_Stats, + Else_Statements => D_Stats)); + end if; Rewrite (N, Make_Block_Statement (Loc, @@ -8481,6 +9897,55 @@ package body Exp_Ch9 is end if; end External_Subprogram; + ------------------------------ + -- Extract_Dispatching_Call -- + ------------------------------ + + procedure Extract_Dispatching_Call + (N : Node_Id; + Call_Ent : out Entity_Id; + Object : out Entity_Id; + Actuals : out List_Id; + Formals : out List_Id) + is + Call_Nam : Node_Id; + + begin + pragma Assert (Nkind (N) = N_Procedure_Call_Statement); + + if Present (Original_Node (N)) then + Call_Nam := Name (Original_Node (N)); + else + Call_Nam := Name (N); + end if; + + -- Retrieve the name of the dispatching procedure. It contains the + -- dispatch table slot number. + + loop + case Nkind (Call_Nam) is + when N_Identifier => + exit; + + when N_Selected_Component => + Call_Nam := Selector_Name (Call_Nam); + + when others => + raise Program_Error; + + end case; + end loop; + + Actuals := Parameter_Associations (N); + Call_Ent := Entity (Call_Nam); + Formals := Parameter_Specifications (Parent (Call_Ent)); + Object := First (Actuals); + + if Present (Original_Node (Object)) then + Object := Original_Node (Object); + end if; + end Extract_Dispatching_Call; + ------------------- -- Extract_Entry -- ------------------- @@ -8502,15 +9967,13 @@ package body Exp_Ch9 is Ename := Selector_Name (Nam); Index := Empty; - -- For a member of an entry family, the name is an indexed - -- component where the prefix is a selected component, - -- whose prefix in turn is the task value, and whose - -- selector is the entry family. The single expression in - -- the expressions list of the indexed component is the - -- subscript for the family. + -- For a member of an entry family, the name is an indexed component + -- where the prefix is a selected component, whose prefix in turn is + -- the task value, and whose selector is the entry family. The single + -- expression in the expressions list of the indexed component is the + -- subscript for the family. - else - pragma Assert (Nkind (Nam) = N_Indexed_Component); + else pragma Assert (Nkind (Nam) = N_Indexed_Component); Concval := Prefix (Prefix (Nam)); Ename := Selector_Name (Prefix (Nam)); Index := First (Expressions (Nam)); @@ -8899,6 +10362,8 @@ package body Exp_Ch9 is if Has_Entry or else Has_Interrupt_Handler (Ptyp) or else Has_Attach_Handler (Ptyp) + or else (Ada_Version >= Ada_05 + and then Present (Interface_List (Parent (Ptyp)))) then -- Compiler_Info parameter. This parameter allows entry body -- procedures and barrier functions to be called from the runtime. @@ -9287,6 +10752,168 @@ package body Exp_Ch9 is return Next_Op; end Next_Protected_Operation; + -------------------------- + -- Parameter_Block_Pack -- + -------------------------- + + function Parameter_Block_Pack + (Loc : Source_Ptr; + Blk_Typ : Entity_Id; + Actuals : List_Id; + Formals : List_Id; + Decls : List_Id; + Stmts : List_Id) return Node_Id + is + Actual : Entity_Id; + Blk_Nam : Node_Id; + Formal : Entity_Id; + Params : List_Id; + Temp_Asn : Node_Id; + Temp_Nam : Node_Id; + + begin + Actual := First (Actuals); + Formal := Defining_Identifier (First (Formals)); + Params := New_List; + + while Present (Actual) loop + if Is_By_Copy_Type (Etype (Actual)) then + -- Generate: + -- Jnn : aliased + + Temp_Nam := + Make_Defining_Identifier (Loc, New_Internal_Name ('J')); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Aliased_Present => + True, + Defining_Identifier => + Temp_Nam, + Object_Definition => + New_Reference_To (Etype (Formal), Loc))); + + if Ekind (Formal) /= E_Out_Parameter then + + -- Generate: + -- Jnn := + + Temp_Asn := + New_Reference_To (Temp_Nam, Loc); + + Set_Assignment_OK (Temp_Asn); + + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => + Temp_Asn, + Expression => + New_Copy_Tree (Actual))); + end if; + + -- Generate: + -- Jnn'unchecked_access + + Append_To (Params, + Make_Attribute_Reference (Loc, + Attribute_Name => + Name_Unchecked_Access, + Prefix => + New_Reference_To (Temp_Nam, Loc))); + else + Append_To (Params, + Make_Reference (Loc, New_Copy_Tree (Actual))); + end if; + + Next_Actual (Actual); + Next_Formal_With_Extras (Formal); + end loop; + + -- Generate: + -- P : Ann := ( + -- J1'unchecked_access; + -- 'reference; + -- ...); + + Blk_Nam := Make_Defining_Identifier (Loc, Name_uP); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + Blk_Nam, + Object_Definition => + New_Reference_To (Blk_Typ, Loc), + Expression => + Make_Aggregate (Loc, Params))); + + -- Return: + -- P'address + + return + Make_Attribute_Reference (Loc, + Attribute_Name => + Name_Address, + Prefix => + New_Reference_To (Blk_Nam, Loc)); + end Parameter_Block_Pack; + + ---------------------------- + -- Parameter_Block_Unpack -- + ---------------------------- + + function Parameter_Block_Unpack + (Loc : Source_Ptr; + Actuals : List_Id; + Formals : List_Id) return List_Id + is + Actual : Entity_Id; + Asnmt : Node_Id; + Formal : Entity_Id; + Result : constant List_Id := New_List; + + At_Least_One_Asnmt : Boolean := False; + + begin + Actual := First (Actuals); + Formal := Defining_Identifier (First (Formals)); + + while Present (Actual) loop + if Is_By_Copy_Type (Etype (Actual)) + and then Ekind (Formal) /= E_In_Parameter + then + At_Least_One_Asnmt := True; + + -- Generate: + -- := P.; + + Asnmt := + Make_Assignment_Statement (Loc, + Name => + New_Copy (Actual), + Expression => + Make_Explicit_Dereference (Loc, + Make_Selected_Component (Loc, + Prefix => + Make_Identifier (Loc, Name_uP), + Selector_Name => + Make_Identifier (Loc, Chars (Formal))))); + + Set_Assignment_OK (Name (Asnmt)); + + Append_To (Result, Asnmt); + end if; + + Next_Actual (Actual); + Next_Formal_With_Extras (Formal); + end loop; + + if At_Least_One_Asnmt then + return Result; + end if; + + return New_List (Make_Null_Statement (Loc)); + end Parameter_Block_Unpack; + ---------------------- -- Set_Discriminals -- ---------------------- @@ -9302,7 +10929,6 @@ package body Exp_Ch9 is if Has_Discriminants (Pdef) then D := First_Discriminant (Pdef); - while Present (D) loop D_Minal := Make_Defining_Identifier (Sloc (D), @@ -9366,11 +10992,10 @@ package body Exp_Ch9 is Set_Esize (Priv, Esize (Etype (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. + -- 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. if Is_Itype (Etype (P_Id)) then Append_Elmt (P_Id, Assoc_L); @@ -9394,9 +11019,8 @@ package body Exp_Ch9 is end loop; end if; - -- There is one more implicit private declaration: the object - -- itself. A "prival" for this is attached to the protected - -- body defining identifier. + -- 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); @@ -9492,11 +11116,12 @@ package body Exp_Ch9 is 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 ??? + -- 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)) @@ -9532,10 +11157,8 @@ package body Exp_Ch9 is 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))); @@ -9550,13 +11173,13 @@ package body Exp_Ch9 is 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 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 diff --git a/gcc/ada/exp_ch9.ads b/gcc/ada/exp_ch9.ads index 2707101..044f56d 100644 --- a/gcc/ada/exp_ch9.ads +++ b/gcc/ada/exp_ch9.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2004 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005 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- -- @@ -30,6 +30,13 @@ with Types; use Types; package Exp_Ch9 is + type Subprogram_Protection_Mode is + (Dispatching_Mode, + Protected_Mode, + Unprotected_Mode); + -- This type is used to distinguish the different protection modes of a + -- protected subprogram. + procedure Add_Discriminal_Declarations (Decls : List_Id; Typ : Entity_Id; @@ -102,10 +109,9 @@ package Exp_Ch9 is -- declarative part. function Build_Protected_Sub_Specification - (N : Node_Id; - Prottyp : Entity_Id; - Unprotected : Boolean := False) - return Node_Id; + (N : Node_Id; + Prottyp : Entity_Id; + Mode : Subprogram_Protection_Mode) return Node_Id; -- Build 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 @@ -214,7 +220,7 @@ package Exp_Ch9 is -- routine to make sure Complete_Master is called on exit). procedure Expand_Access_Protected_Subprogram_Type (N : Node_Id); - -- Build Equivalent_Type for an Access_to_protected_Subprogram. + -- Build Equivalent_Type for an Access_to_protected_Subprogram procedure Expand_Accept_Declarations (N : Node_Id; Ent : Entity_Id); -- Expand declarations required for accept statement. See bodies of diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 05ecfb6..524d6de 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -49,19 +49,276 @@ with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; with Tbuild; use Tbuild; -with Ttypes; use Ttypes; with Uintp; use Uintp; package body Exp_Disp is + -------------------------------- + -- Select_Expansion_Utilities -- + -------------------------------- + + -- The following package contains helper routines used in the expansion of + -- dispatching asynchronous, conditional and timed selects. + + package Select_Expansion_Utilities is + procedure Build_B + (Loc : Source_Ptr; + Params : List_Id); + -- Generate: + -- B : out Communication_Block + + procedure Build_C + (Loc : Source_Ptr; + Params : List_Id); + -- Generate: + -- C : out Prim_Op_Kind + + procedure Build_Common_Dispatching_Select_Statements + (Loc : Source_Ptr; + Typ : Entity_Id; + Stmts : List_Id); + -- Ada 2005 (AI-345): Generate statements that are common between + -- asynchronous, conditional and timed select expansion. + + procedure Build_F + (Loc : Source_Ptr; + Params : List_Id); + -- Generate: + -- F : out Boolean + + procedure Build_P + (Loc : Source_Ptr; + Params : List_Id); + -- Generate: + -- P : Address + + procedure Build_S + (Loc : Source_Ptr; + Params : List_Id); + -- Generate: + -- S : Integer + + procedure Build_T + (Loc : Source_Ptr; + Typ : Entity_Id; + Params : List_Id); + -- Generate: + -- T : in out Typ + end Select_Expansion_Utilities; + + package body Select_Expansion_Utilities is + + ------------- + -- Build_B -- + ------------- + + procedure Build_B + (Loc : Source_Ptr; + Params : List_Id) + is + begin + Append_To (Params, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uB), + Parameter_Type => + New_Reference_To (RTE (RE_Communication_Block), Loc), + Out_Present => True)); + end Build_B; + + ------------- + -- Build_C -- + ------------- + + procedure Build_C + (Loc : Source_Ptr; + Params : List_Id) + is + begin + Append_To (Params, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uC), + Parameter_Type => + New_Reference_To (RTE (RE_Prim_Op_Kind), Loc), + Out_Present => True)); + end Build_C; + + ------------------------------------------------ + -- Build_Common_Dispatching_Select_Statements -- + ------------------------------------------------ + + procedure Build_Common_Dispatching_Select_Statements + (Loc : Source_Ptr; + Typ : Entity_Id; + Stmts : List_Id) + is + DT_Ptr : Entity_Id; + DT_Ptr_Typ : Entity_Id := Typ; + + begin + -- Typ may be a derived type, climb the derivation chain in order to + -- find the root. + + while Present (Parent_Subtype (DT_Ptr_Typ)) loop + DT_Ptr_Typ := Parent_Subtype (DT_Ptr_Typ); + end loop; + + DT_Ptr := Node (First_Elmt (Access_Disp_Table (DT_Ptr_Typ))); + + -- Generate: + -- C := get_prim_op_kind (tag! (VP), S); + + -- where C is the out parameter capturing the call kind and S is the + -- dispatch table slot number. + + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => + Make_Identifier (Loc, Name_uC), + Expression => + Make_DT_Access_Action (Typ, + Action => + Get_Prim_Op_Kind, + Args => + New_List ( + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (DT_Ptr, Loc)), + Make_Identifier (Loc, Name_uS))))); + + -- Generate: + -- if C = POK_Procedure + -- or else C = POK_Protected_Procedure + -- or else C = POK_Task_Procedure; + -- then + -- F := True; + -- return; + + -- where F is the out parameter capturing the status of a potential + -- entry call. + + Append_To (Stmts, + Make_If_Statement (Loc, + + Condition => + Make_Or_Else (Loc, + Left_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + Make_Identifier (Loc, Name_uC), + Right_Opnd => + New_Reference_To (RTE (RE_POK_Procedure), Loc)), + Right_Opnd => + Make_Or_Else (Loc, + Left_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + Make_Identifier (Loc, Name_uC), + Right_Opnd => + New_Reference_To (RTE ( + RE_POK_Protected_Procedure), Loc)), + Right_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + Make_Identifier (Loc, Name_uC), + Right_Opnd => + New_Reference_To (RTE ( + RE_POK_Task_Procedure), Loc)))), + + Then_Statements => + New_List ( + Make_Assignment_Statement (Loc, + Name => Make_Identifier (Loc, Name_uF), + Expression => New_Reference_To (Standard_True, Loc)), + + Make_Return_Statement (Loc)))); + end Build_Common_Dispatching_Select_Statements; + + ------------- + -- Build_F -- + ------------- + + procedure Build_F + (Loc : Source_Ptr; + Params : List_Id) + is + begin + Append_To (Params, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uF), + Parameter_Type => + New_Reference_To (Standard_Boolean, Loc), + Out_Present => True)); + end Build_F; + + ------------- + -- Build_P -- + ------------- + + procedure Build_P + (Loc : Source_Ptr; + Params : List_Id) + is + begin + Append_To (Params, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uP), + Parameter_Type => + New_Reference_To (RTE (RE_Address), Loc))); + end Build_P; + + ------------- + -- Build_S -- + ------------- + + procedure Build_S + (Loc : Source_Ptr; + Params : List_Id) + is + begin + Append_To (Params, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uS), + Parameter_Type => + New_Reference_To (Standard_Integer, Loc))); + end Build_S; + + ------------- + -- Build_T -- + ------------- + + procedure Build_T + (Loc : Source_Ptr; + Typ : Entity_Id; + Params : List_Id) + is + begin + Append_To (Params, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uT), + Parameter_Type => + New_Reference_To (Typ, Loc), + In_Present => True, + Out_Present => True)); + end Build_T; + end Select_Expansion_Utilities; + + package SEU renames Select_Expansion_Utilities; + Ada_Actions : constant array (DT_Access_Action) of RE_Id := (CW_Membership => RE_CW_Membership, IW_Membership => RE_IW_Membership, DT_Entry_Size => RE_DT_Entry_Size, DT_Prologue_Size => RE_DT_Prologue_Size, Get_Access_Level => RE_Get_Access_Level, + Get_Entry_Index => RE_Get_Entry_Index, Get_External_Tag => RE_Get_External_Tag, Get_Prim_Op_Address => RE_Get_Prim_Op_Address, + Get_Prim_Op_Kind => RE_Get_Prim_Op_Kind, Get_RC_Offset => RE_Get_RC_Offset, Get_Remotely_Callable => RE_Get_Remotely_Callable, Inherit_DT => RE_Inherit_DT, @@ -69,9 +326,11 @@ package body Exp_Disp is Register_Interface_Tag => RE_Register_Interface_Tag, Register_Tag => RE_Register_Tag, Set_Access_Level => RE_Set_Access_Level, + Set_Entry_Index => RE_Set_Entry_Index, Set_Expanded_Name => RE_Set_Expanded_Name, Set_External_Tag => RE_Set_External_Tag, Set_Prim_Op_Address => RE_Set_Prim_Op_Address, + Set_Prim_Op_Kind => RE_Set_Prim_Op_Kind, Set_RC_Offset => RE_Set_RC_Offset, Set_Remotely_Callable => RE_Set_Remotely_Callable, Set_TSD => RE_Set_TSD, @@ -84,8 +343,10 @@ package body Exp_Disp is DT_Entry_Size => False, DT_Prologue_Size => False, Get_Access_Level => False, + Get_Entry_Index => False, Get_External_Tag => False, Get_Prim_Op_Address => False, + Get_Prim_Op_Kind => False, Get_Remotely_Callable => False, Get_RC_Offset => False, Inherit_DT => True, @@ -93,9 +354,11 @@ package body Exp_Disp is Register_Interface_Tag => True, Register_Tag => True, Set_Access_Level => True, + Set_Entry_Index => True, Set_Expanded_Name => True, Set_External_Tag => True, Set_Prim_Op_Address => True, + Set_Prim_Op_Kind => True, Set_RC_Offset => True, Set_Remotely_Callable => True, Set_TSD => True, @@ -108,8 +371,10 @@ package body Exp_Disp is DT_Entry_Size => 0, DT_Prologue_Size => 0, Get_Access_Level => 1, + Get_Entry_Index => 2, Get_External_Tag => 1, Get_Prim_Op_Address => 2, + Get_Prim_Op_Kind => 2, Get_RC_Offset => 1, Get_Remotely_Callable => 1, Inherit_DT => 3, @@ -117,21 +382,17 @@ package body Exp_Disp is Register_Interface_Tag => 2, Register_Tag => 1, Set_Access_Level => 2, + Set_Entry_Index => 3, Set_Expanded_Name => 2, Set_External_Tag => 2, Set_Prim_Op_Address => 3, + Set_Prim_Op_Kind => 3, Set_RC_Offset => 2, Set_Remotely_Callable => 2, Set_TSD => 2, TSD_Entry_Size => 0, TSD_Prologue_Size => 0); - function Build_Anonymous_Access_Type - (Directly_Designated_Type : Entity_Id; - Related_Nod : Node_Id) return Entity_Id; - -- Returns a decorated entity corresponding with an anonymous access type. - -- Used to generate unchecked type conversion of an address. - procedure Collect_All_Interfaces (T : Entity_Id); -- Ada 2005 (AI-251): Collect the whole list of interfaces that are -- directly or indirectly implemented by T. Used to compute the size @@ -145,29 +406,12 @@ package body Exp_Disp is -- Check if the type has a private view or if the public view appears -- in the visible part of a package spec. - ---------------------------------- - -- Build_Anonymous_Access_Type -- - ---------------------------------- - - function Build_Anonymous_Access_Type - (Directly_Designated_Type : Entity_Id; - Related_Nod : Node_Id) return Entity_Id - is - New_E : Entity_Id; - - begin - New_E := Create_Itype (Ekind => E_Anonymous_Access_Type, - Related_Nod => Related_Nod, - Scope_Id => Current_Scope); - - Set_Etype (New_E, New_E); - Init_Size_Align (New_E); - Init_Size (New_E, System_Address_Size); - Set_Directly_Designated_Type (New_E, Directly_Designated_Type); - Set_Is_First_Subtype (New_E); - - return New_E; - end Build_Anonymous_Access_Type; + function Prim_Op_Kind + (Prim : Entity_Id; + Typ : Entity_Id) return Node_Id; + -- Ada 2005 (AI-345): Determine the primitive operation kind of Prim + -- according to its type Typ. Return a reference to an RTE Prim_Op_Kind + -- enumeration value. ---------------------------- -- Collect_All_Interfaces -- @@ -187,9 +431,10 @@ package body Exp_Disp is ------------------- procedure Add_Interface (Iface : Entity_Id) is - Elmt : Elmt_Id := First_Elmt (Abstract_Interfaces (T)); + Elmt : Elmt_Id; begin + Elmt := First_Elmt (Abstract_Interfaces (T)); while Present (Elmt) and then Node (Elmt) /= Iface loop Next_Elmt (Elmt); end loop; @@ -238,9 +483,7 @@ package body Exp_Disp is if Is_Non_Empty_List (Interface_List (Nod)) then Id := First (Interface_List (Nod)); - while Present (Id) loop - Iface := Etype (Id); if Is_Interface (Iface) then @@ -309,6 +552,18 @@ package body Exp_Disp is elsif TSS_Name = TSS_Deep_Finalize then return Uint_10; + elsif Chars (E) = Name_uDisp_Asynchronous_Select then + return Uint_11; + + elsif Chars (E) = Name_uDisp_Conditional_Select then + return Uint_12; + + elsif Chars (E) = Name_uDisp_Get_Prim_Op_Kind then + return Uint_13; + + elsif Chars (E) = Name_uDisp_Timed_Select then + return Uint_14; + else raise Program_Error; end if; @@ -373,9 +628,10 @@ package body Exp_Disp is else declare - Formal : Entity_Id := First_Formal (Subp); + Formal : Entity_Id; begin + Formal := First_Formal (Subp); while Present (Formal) loop if Is_Controlling_Formal (Formal) then if Is_Access_Type (Etype (Formal)) then @@ -441,6 +697,10 @@ package body Exp_Disp is Typ := Root_Type (CW_Typ); + if Ekind (Typ) = E_Incomplete_Type then + Typ := Non_Limited_View (Typ); + end if; + if not Is_Limited_Type (Typ) then Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq); end if; @@ -744,13 +1004,17 @@ package body Exp_Disp is Loc : constant Source_Ptr := Sloc (N); Operand : constant Node_Id := Expression (N); Operand_Typ : Entity_Id := Etype (Operand); - Target_Type : Entity_Id := Etype (N); + Iface_Typ : Entity_Id := Etype (N); Iface_Tag : Entity_Id; + Fent : Entity_Id; + Func : Node_Id; + P : Node_Id; + Null_Op_Nod : Node_Id; begin pragma Assert (Nkind (Operand) /= N_Attribute_Reference); - -- Ada 2005 (AI-345): Set Operand_Typ and Handle task interfaces + -- Ada 2005 (AI-345): Handle task interfaces if Ekind (Operand_Typ) = E_Task_Type or else Ekind (Operand_Typ) = E_Protected_Type @@ -758,27 +1022,126 @@ package body Exp_Disp is Operand_Typ := Corresponding_Record_Type (Operand_Typ); end if; - if Is_Access_Type (Target_Type) then - Target_Type := Etype (Directly_Designated_Type (Target_Type)); + -- Handle access types to interfaces - elsif Is_Class_Wide_Type (Target_Type) then - Target_Type := Etype (Target_Type); + if Is_Access_Type (Iface_Typ) then + Iface_Typ := Etype (Directly_Designated_Type (Iface_Typ)); end if; - pragma Assert (not Is_Class_Wide_Type (Target_Type) - and then Is_Interface (Target_Type)); + -- Handle class-wide interface types. This conversion can appear + -- explicitly in the source code. Example: I'Class (Obj) - Iface_Tag := Find_Interface_Tag (Operand_Typ, Target_Type); + if Is_Class_Wide_Type (Iface_Typ) then + Iface_Typ := Etype (Iface_Typ); + end if; + + pragma Assert (not Is_Class_Wide_Type (Iface_Typ) + and then Is_Interface (Iface_Typ)); + Iface_Tag := Find_Interface_Tag (Operand_Typ, Iface_Typ); pragma Assert (Iface_Tag /= Empty); - Rewrite (N, - Unchecked_Convert_To (Etype (N), - Make_Attribute_Reference (Loc, - Prefix => Make_Selected_Component (Loc, - Prefix => Relocate_Node (Expression (N)), - Selector_Name => New_Occurrence_Of (Iface_Tag, Loc)), - Attribute_Name => Name_Address))); + -- Keep separate access types to interfaces because one internal + -- function is used to handle the null value (see following comment) + + if not Is_Access_Type (Etype (N)) then + Rewrite (N, + Unchecked_Convert_To (Etype (N), + Make_Selected_Component (Loc, + Prefix => Relocate_Node (Expression (N)), + Selector_Name => + New_Occurrence_Of (Iface_Tag, Loc)))); + + else + -- Build internal function to handle the case in which the + -- actual is null. If the actual is null returns null because + -- no displacement is required; otherwise performs a type + -- conversion that will be expanded in the code that returns + -- the value of the displaced actual. That is: + + -- function Func (O : Operand_Typ) return Iface_Typ is + -- begin + -- if O = null then + -- return null; + -- else + -- return Iface_Typ!(O); + -- end if; + -- end Func; + + Fent := + Make_Defining_Identifier (Loc, New_Internal_Name ('F')); + + -- Decorate the "null" in the if-statement condition + + Null_Op_Nod := Make_Null (Loc); + Set_Etype (Null_Op_Nod, Etype (Operand)); + Set_Analyzed (Null_Op_Nod); + + Func := + Make_Subprogram_Body (Loc, + Specification => + Make_Function_Specification (Loc, + Defining_Unit_Name => Fent, + + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uO), + Parameter_Type => + New_Reference_To (Etype (Operand), Loc))), + Result_Definition => + New_Reference_To (Etype (N), Loc)), + + Declarations => Empty_List, + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_If_Statement (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => Make_Identifier (Loc, Name_uO), + Right_Opnd => Null_Op_Nod), + Then_Statements => New_List ( + Make_Return_Statement (Loc, + Make_Null (Loc))), + Else_Statements => New_List ( + Make_Return_Statement (Loc, + Unchecked_Convert_To (Etype (N), + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => Relocate_Node (Expression (N)), + Selector_Name => + New_Occurrence_Of (Iface_Tag, Loc)), + Attribute_Name => Name_Address)))))))); + + -- Insert the new declaration in the nearest enclosing scope + -- that has declarations. + + P := N; + while not Has_Declarations (Parent (P)) loop + P := Parent (P); + end loop; + + if Is_List_Member (P) then + Insert_Before (P, Func); + + elsif Nkind (Parent (P)) = N_Package_Specification then + Append_To (Visible_Declarations (Parent (P)), Func); + + else + Append_To (Declarations (Parent (P)), Func); + end if; + + Analyze (Func); + + Rewrite (N, + Make_Function_Call (Loc, + Name => New_Reference_To (Fent, Loc), + Parameter_Associations => New_List ( + Relocate_Node (Expression (N))))); + end if; Analyze (N); end Expand_Interface_Conversion; @@ -790,12 +1153,16 @@ package body Exp_Disp is procedure Expand_Interface_Actuals (Call_Node : Node_Id) is Loc : constant Source_Ptr := Sloc (Call_Node); Actual : Node_Id; + Actual_Dup : Node_Id; Actual_Typ : Entity_Id; + Anon : Entity_Id; Conversion : Node_Id; Formal : Entity_Id; Formal_Typ : Entity_Id; Subp : Entity_Id; Nam : Name_Id; + Formal_DDT : Entity_Id; + Actual_DDT : Entity_Id; begin -- This subprogram is called directly from the semantics, so we need a @@ -818,45 +1185,70 @@ package body Exp_Disp is Formal := First_Formal (Subp); Actual := First_Actual (Call_Node); - while Present (Formal) loop - pragma Assert (Ekind (Etype (Etype (Formal))) - /= E_Record_Type_With_Private); - -- Ada 2005 (AI-251): Conversion to interface to force "this" - -- displacement + -- displacement. Formal_Typ := Etype (Etype (Formal)); + + if Ekind (Formal_Typ) = E_Record_Type_With_Private then + Formal_Typ := Full_View (Formal_Typ); + end if; + + if Is_Access_Type (Formal_Typ) then + Formal_DDT := Directly_Designated_Type (Formal_Typ); + end if; + Actual_Typ := Etype (Actual); + if Is_Access_Type (Actual_Typ) then + Actual_DDT := Directly_Designated_Type (Actual_Typ); + end if; + if Is_Interface (Formal_Typ) then - Conversion := Convert_To (Formal_Typ, New_Copy_Tree (Actual)); - Rewrite (Actual, Conversion); - Analyze_And_Resolve (Actual, Formal_Typ); + -- No need to displace the pointer if the type of the actual + -- is class-wide of the formal-type interface; in this case the + -- displacement of the pointer was already done at the point of + -- the call to the enclosing subprogram. This case corresponds + -- with the call to P (Obj) in the following example: - Rewrite (Actual, - Make_Explicit_Dereference (Loc, - Unchecked_Convert_To - (Build_Anonymous_Access_Type (Formal_Typ, Call_Node), - Relocate_Node (Expression (Actual))))); + -- type I is interface; + -- procedure P (X : I) is abstract; + + -- procedure General_Op (Obj : I'Class) is + -- begin + -- P (Obj); + -- end General_Op; + + if Is_Class_Wide_Type (Actual_Typ) + and then Etype (Actual_Typ) = Formal_Typ + then + null; + + -- No need to displace the pointer if the type of the actual is a + -- derivation of the formal-type interface because in this case + -- the interface primitives are located in the primary dispatch + -- table. - Analyze_And_Resolve (Actual, Formal_Typ); + elsif Is_Ancestor (Formal_Typ, Actual_Typ) then + null; + + else + Conversion := Convert_To (Formal_Typ, Relocate_Node (Actual)); + Rewrite (Actual, Conversion); + Analyze_And_Resolve (Actual, Formal_Typ); + end if; -- Anonymous access type elsif Is_Access_Type (Formal_Typ) - and then Is_Interface (Etype - (Directly_Designated_Type - (Formal_Typ))) + and then Is_Interface (Etype (Formal_DDT)) and then Interface_Present_In_Ancestor - (Typ => Etype (Directly_Designated_Type - (Actual_Typ)), - Iface => Etype (Directly_Designated_Type - (Formal_Typ))) + (Typ => Actual_DDT, + Iface => Etype (Formal_DDT)) then - if Nkind (Actual) = N_Attribute_Reference and then (Attribute_Name (Actual) = Name_Access @@ -864,29 +1256,85 @@ package body Exp_Disp is then Nam := Attribute_Name (Actual); - Conversion := - Convert_To - (Etype (Directly_Designated_Type (Formal_Typ)), - Prefix (Actual)); + Conversion := Convert_To (Etype (Formal_DDT), Prefix (Actual)); Rewrite (Actual, Conversion); - - Analyze_And_Resolve (Actual, - Etype (Directly_Designated_Type (Formal_Typ))); + Analyze_And_Resolve (Actual, Etype (Formal_DDT)); Rewrite (Actual, Unchecked_Convert_To (Formal_Typ, Make_Attribute_Reference (Loc, - Prefix => - Relocate_Node (Prefix (Expression (Actual))), + Prefix => Relocate_Node (Actual), Attribute_Name => Nam))); Analyze_And_Resolve (Actual, Formal_Typ); + -- No need to displace the pointer if the actual is a class-wide + -- type of the formal-type interface because in this case the + -- displacement of the pointer was already done at the point of + -- the call to the enclosing subprogram (this case is similar + -- to the example described above for the non access-type case) + + elsif Is_Class_Wide_Type (Actual_DDT) + and then Etype (Actual_DDT) = Formal_DDT + then + null; + + -- No need to displace the pointer if the type of the actual is a + -- derivation of the interface (because in this case the interface + -- primitives are located in the primary dispatch table) + + elsif Is_Ancestor (Formal_DDT, Actual_DDT) then + null; + else - Conversion := - Convert_To (Formal_Typ, New_Copy_Tree (Actual)); - Rewrite (Actual, Conversion); + Actual_Dup := Relocate_Node (Actual); + + if From_With_Type (Actual_Typ) then + + -- If the type of the actual parameter comes from a limited + -- with-clause and the non-limited view is already available + -- we replace the anonymous access type by a duplicate decla + -- ration whose designated type is the non-limited view + + if Ekind (Actual_DDT) = E_Incomplete_Type + and then Present (Non_Limited_View (Actual_DDT)) + then + Anon := New_Copy (Actual_Typ); + + if Is_Itype (Anon) then + Set_Scope (Anon, Current_Scope); + end if; + + Set_Directly_Designated_Type (Anon, + Non_Limited_View (Actual_DDT)); + Set_Etype (Actual_Dup, Anon); + + elsif Is_Class_Wide_Type (Actual_DDT) + and then Ekind (Etype (Actual_DDT)) = E_Incomplete_Type + and then Present (Non_Limited_View (Etype (Actual_DDT))) + then + Anon := New_Copy (Actual_Typ); + + if Is_Itype (Anon) then + Set_Scope (Anon, Current_Scope); + end if; + + Set_Directly_Designated_Type (Anon, + New_Copy (Actual_DDT)); + Set_Class_Wide_Type (Directly_Designated_Type (Anon), + New_Copy (Class_Wide_Type (Actual_DDT))); + Set_Etype (Directly_Designated_Type (Anon), + Non_Limited_View (Etype (Actual_DDT))); + Set_Etype ( + Class_Wide_Type (Directly_Designated_Type (Anon)), + Non_Limited_View (Etype (Actual_DDT))); + Set_Etype (Actual_Dup, Anon); + end if; + end if; + + Conversion := Convert_To (Formal_Typ, Actual_Dup); + Rewrite (Actual, Conversion); Analyze_And_Resolve (Actual, Formal_Typ); end if; end if; @@ -904,40 +1352,38 @@ package body Exp_Disp is (N : Node_Id; Thunk_Alias : Entity_Id; Thunk_Id : Entity_Id; - Iface_Tag : Entity_Id) return Node_Id + Thunk_Tag : Entity_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (N); Actuals : constant List_Id := New_List; Decl : constant List_Id := New_List; Formals : constant List_Id := New_List; - Thunk_Tag : constant Node_Id := Iface_Tag; Target : Entity_Id; New_Code : Node_Id; Formal : Node_Id; New_Formal : Node_Id; Decl_1 : Node_Id; Decl_2 : Node_Id; - Subtyp_Mark : Node_Id; + E : Entity_Id; begin - -- Traverse the list of alias to find the final target Target := Thunk_Alias; - while Present (Alias (Target)) loop Target := Alias (Target); end loop; -- Duplicate the formals - Formal := First_Formal (Thunk_Alias); - + Formal := First_Formal (Target); + E := First_Formal (N); while Present (Formal) loop New_Formal := Copy_Separate_Tree (Parent (Formal)); - -- Handle the case in which the subprogram covering - -- the interface has been inherited: + -- Propagate the parameter type to the copy. This is required to + -- properly handle the case in which the subprogram covering the + -- interface has been inherited: -- Example: -- type I is interface; @@ -948,20 +1394,17 @@ package body Exp_Disp is -- type DT is new T and I with ... - if Is_Controlling_Formal (Formal) then - Set_Parameter_Type (New_Formal, - New_Reference_To (Etype (First_Entity (N)), Loc)); - end if; - + Set_Parameter_Type (New_Formal, New_Reference_To (Etype (E), Loc)); Append_To (Formals, New_Formal); + Next_Formal (Formal); + Next_Formal (E); end loop; - if Ekind (First_Formal (Thunk_Alias)) = E_In_Parameter - and then Ekind (Etype (First_Formal (Thunk_Alias))) + if Ekind (First_Formal (Target)) = E_In_Parameter + and then Ekind (Etype (First_Formal (Target))) = E_Anonymous_Access_Type then - -- Generate: -- type T is access all <> @@ -983,8 +1426,7 @@ package body Exp_Disp is Subtype_Indication => New_Reference_To (Directly_Designated_Type - (Etype (First_Formal (Thunk_Alias))), Loc) - )); + (Etype (First_Formal (Target))), Loc))); Decl_1 := Make_Object_Declaration (Loc, @@ -1095,7 +1537,7 @@ package body Exp_Disp is Next (Formal); end loop; - if Ekind (Thunk_Alias) = E_Procedure then + if Ekind (Target) = E_Procedure then New_Code := Make_Subprogram_Body (Loc, Specification => @@ -1110,23 +1552,7 @@ package body Exp_Disp is Name => New_Occurrence_Of (Target, Loc), Parameter_Associations => Actuals)))); - else pragma Assert (Ekind (Thunk_Alias) = E_Function); - - if not Present (Alias (Thunk_Alias)) then - Subtyp_Mark := Subtype_Mark (Parent (Thunk_Alias)); - else - -- The last element in the alias list has the correct subtype_mark - -- of the function result - - declare - E : Entity_Id := Alias (Thunk_Alias); - begin - while Present (Alias (E)) loop - E := Alias (E); - end loop; - Subtyp_Mark := Subtype_Mark (Parent (E)); - end; - end if; + else pragma Assert (Ekind (Target) = E_Function); New_Code := Make_Subprogram_Body (Loc, @@ -1134,7 +1560,8 @@ package body Exp_Disp is Make_Function_Specification (Loc, Defining_Unit_Name => Thunk_Id, Parameter_Specifications => Formals, - Subtype_Mark => New_Copy (Subtyp_Mark)), + Result_Definition => + New_Copy (Result_Definition (Parent (Target)))), Declarations => Decl, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, @@ -1234,6 +1661,49 @@ package body Exp_Disp is Selector_Name => Make_Identifier (Loc, Name_uTag)))); end Get_Remotely_Callable; + ------------------------------------------ + -- Init_Predefined_Interface_Primitives -- + ------------------------------------------ + + function Init_Predefined_Interface_Primitives + (Typ : Entity_Id) return List_Id + is + Loc : constant Source_Ptr := Sloc (Typ); + DT_Ptr : constant Node_Id := + Node (First_Elmt (Access_Disp_Table (Typ))); + Result : constant List_Id := New_List; + AI : Elmt_Id; + + begin + -- No need to inherit primitives if it an abstract interface type + + if Is_Interface (Typ) then + return Result; + end if; + + AI := Next_Elmt (First_Elmt (Access_Disp_Table (Typ))); + while Present (AI) loop + -- All the secondary tables inherit the dispatch table entries + -- associated with predefined primitives. + + -- Generate: + -- Inherit_DT (T'Tag, Iface'Tag, Default_Prim_Op_Count); + + Append_To (Result, + Make_DT_Access_Action (Typ, + Action => Inherit_DT, + Args => New_List ( + Node1 => New_Reference_To (DT_Ptr, Loc), + Node2 => Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (Node (AI), Loc)), + Node3 => Make_Integer_Literal (Loc, Default_Prim_Op_Count)))); + + Next_Elmt (AI); + end loop; + + return Result; + end Init_Predefined_Interface_Primitives; + ------------- -- Make_DT -- ------------- @@ -1283,8 +1753,7 @@ package body Exp_Disp is -- Calculate the number of entries required in the table of interfaces Num_Ifaces := 0; - AI := First_Elmt (Abstract_Interfaces (Typ_Copy)); - + AI := First_Elmt (Abstract_Interfaces (Typ_Copy)); while Present (AI) loop Num_Ifaces := Num_Ifaces + 1; Next_Elmt (AI); @@ -1300,7 +1769,6 @@ package body Exp_Disp is begin I_Depth := 0; - loop P := Etype (Parent_Type); @@ -1315,9 +1783,25 @@ package body Exp_Disp is end loop; end; - TSD_Num_Entries := I_Depth + Num_Ifaces + 1; Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ))); + -- Ada 2005 (AI-345): The size of the TSD is increased to accomodate + -- the two tables used for dispatching in asynchronous, conditional + -- and timed selects. The tables are solely generated for limited + -- types that implement a limited interface. + + if Ada_Version >= Ada_05 + and then not Is_Interface (Typ) + and then not Is_Abstract (Typ) + and then not Is_Controlled (Typ) + and then Implements_Limited_Interface (Typ) + then + TSD_Num_Entries := I_Depth + Num_Ifaces + 1 + + 2 * (Nb_Prim - Default_Prim_Op_Count); + else + TSD_Num_Entries := I_Depth + Num_Ifaces + 1; + end if; + -- ---------------------------------------------------------------- -- Dispatch table and related entities are allocated statically @@ -1400,7 +1884,7 @@ package body Exp_Disp is -- Generate code to define the boolean that controls registration, in -- order to avoid multiple registrations for tagged types defined in - -- multiple-called scopes + -- multiple-called scopes. Append_To (Result, Make_Object_Declaration (Loc, @@ -1418,7 +1902,7 @@ package body Exp_Disp is -- Generate code to create the storage for the type specific data object -- with enough space to store the tags of the ancestors plus the tags - -- of all the implemented interfaces (as described in a-tags.adb) + -- of all the implemented interfaces (as described in a-tags.adb). -- -- TSD: Storage_Array -- (1..TSD_Prologue_Size+TSD_Num_Entries*TSD_Entry_Size); @@ -1532,83 +2016,94 @@ package body Exp_Disp is (Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc); end if; - -- Generate: Inherit_DT (parent'tag, DT_Ptr, nb_prim of parent); - - Append_To (Elab_Code, - Make_DT_Access_Action (Typ, - Action => Inherit_DT, - Args => New_List ( - Node1 => Old_Tag1, - Node2 => New_Reference_To (DT_Ptr, Loc), - Node3 => Make_Integer_Literal (Loc, - DT_Entry_Count (First_Tag_Component (Etype (Typ))))))); + if Typ /= Etype (Typ) + and then not Is_Interface (Typ) + and then not Is_Interface (Etype (Typ)) + then + -- Generate: Inherit_DT (parent'tag, DT_Ptr, nb_prim of parent); - -- Inherit the secondary dispatch tables of the ancestor + Append_To (Elab_Code, + Make_DT_Access_Action (Typ, + Action => Inherit_DT, + Args => New_List ( + Node1 => Old_Tag1, + Node2 => New_Reference_To (DT_Ptr, Loc), + Node3 => + Make_Integer_Literal (Loc, + DT_Entry_Count (First_Tag_Component (Etype (Typ))))))); - if not Is_CPP_Class (Etype (Typ)) then - declare - Sec_DT_Ancestor : Elmt_Id := - Next_Elmt (First_Elmt (Access_Disp_Table (Etype (Typ)))); - Sec_DT_Typ : Elmt_Id := - Next_Elmt (First_Elmt (Access_Disp_Table (Typ))); + -- Inherit the secondary dispatch tables of the ancestor - procedure Copy_Secondary_DTs (Typ : Entity_Id); - -- ??? comment required + if not Is_CPP_Class (Etype (Typ)) then + declare + Sec_DT_Ancestor : Elmt_Id := + Next_Elmt + (First_Elmt + (Access_Disp_Table (Etype (Typ)))); + Sec_DT_Typ : Elmt_Id := + Next_Elmt + (First_Elmt + (Access_Disp_Table (Typ))); + + procedure Copy_Secondary_DTs (Typ : Entity_Id); + -- Local procedure required to climb through the ancestors and + -- copy the contents of all their secondary dispatch tables. + + ------------------------ + -- Copy_Secondary_DTs -- + ------------------------ + + procedure Copy_Secondary_DTs (Typ : Entity_Id) is + E : Entity_Id; - ------------------------ - -- Copy_Secondary_DTs -- - ------------------------ + begin + if Etype (Typ) /= Typ then + Copy_Secondary_DTs (Etype (Typ)); + end if; - procedure Copy_Secondary_DTs (Typ : Entity_Id) is - E : Entity_Id; + if Present (Abstract_Interfaces (Typ)) + and then not Is_Empty_Elmt_List + (Abstract_Interfaces (Typ)) + then + E := First_Entity (Typ); + while Present (E) + and then Present (Node (Sec_DT_Ancestor)) + loop + if Is_Tag (E) and then Chars (E) /= Name_uTag then + Append_To (Elab_Code, + Make_DT_Access_Action (Typ, + Action => Inherit_DT, + Args => New_List ( + Node1 => Unchecked_Convert_To + (RTE (RE_Tag), + New_Reference_To + (Node (Sec_DT_Ancestor), Loc)), + Node2 => Unchecked_Convert_To + (RTE (RE_Tag), + New_Reference_To + (Node (Sec_DT_Typ), Loc)), + Node3 => Make_Integer_Literal (Loc, + DT_Entry_Count (E))))); + + Next_Elmt (Sec_DT_Ancestor); + Next_Elmt (Sec_DT_Typ); + end if; + + Next_Entity (E); + end loop; + end if; + end Copy_Secondary_DTs; begin - if Etype (Typ) /= Typ then - Copy_Secondary_DTs (Etype (Typ)); + if Present (Node (Sec_DT_Ancestor)) then + Copy_Secondary_DTs (Typ); end if; - - if Present (Abstract_Interfaces (Typ)) - and then not Is_Empty_Elmt_List - (Abstract_Interfaces (Typ)) - then - E := First_Entity (Typ); - - while Present (E) - and then Present (Node (Sec_DT_Ancestor)) - loop - if Is_Tag (E) and then Chars (E) /= Name_uTag then - Append_To (Elab_Code, - Make_DT_Access_Action (Typ, - Action => Inherit_DT, - Args => New_List ( - Node1 => Unchecked_Convert_To - (RTE (RE_Tag), - New_Reference_To - (Node (Sec_DT_Ancestor), Loc)), - Node2 => Unchecked_Convert_To - (RTE (RE_Tag), - New_Reference_To - (Node (Sec_DT_Typ), Loc)), - Node3 => Make_Integer_Literal (Loc, - DT_Entry_Count (E))))); - - Next_Elmt (Sec_DT_Ancestor); - Next_Elmt (Sec_DT_Typ); - end if; - - Next_Entity (E); - end loop; - end if; - end Copy_Secondary_DTs; - - begin - if Present (Node (Sec_DT_Ancestor)) then - Copy_Secondary_DTs (Typ); - end if; - end; + end; + end if; end if; - -- Generate: Inherit_TSD (parent'tag, DT_Ptr); + -- Generate: + -- Inherit_TSD (parent'tag, DT_Ptr); Append_To (Elab_Code, Make_DT_Access_Action (Typ, @@ -1962,6 +2457,832 @@ package body Exp_Disp is end if; end Make_DT_Access_Action; + ---------------------------------------- + -- Make_Disp_Asynchronous_Select_Body -- + ---------------------------------------- + + function Make_Disp_Asynchronous_Select_Body + (Typ : Entity_Id) return Node_Id + is + Conc_Typ : Entity_Id := Empty; + Decls : constant List_Id := New_List; + DT_Ptr : Entity_Id; + DT_Ptr_Typ : Entity_Id; + Loc : constant Source_Ptr := Sloc (Typ); + Stmts : constant List_Id := New_List; + + begin + if Is_Concurrent_Record_Type (Typ) then + Conc_Typ := Corresponding_Concurrent_Type (Typ); + end if; + + -- Typ may be a derived type, climb the derivation chain in order to + -- find the root. + + DT_Ptr_Typ := Typ; + while Present (Parent_Subtype (DT_Ptr_Typ)) loop + DT_Ptr_Typ := Parent_Subtype (DT_Ptr_Typ); + end loop; + + DT_Ptr := Node (First_Elmt (Access_Disp_Table (DT_Ptr_Typ))); + + if Present (Conc_Typ) then + + -- Generate: + -- I : Integer := get_entry_index (tag! (VP), S); + + -- where I will be used to capture the entry index of the primitive + -- wrapper at position S. + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uI), + Object_Definition => + New_Reference_To (Standard_Integer, Loc), + Expression => + Make_DT_Access_Action (Typ, + Action => + Get_Entry_Index, + Args => + New_List ( + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (DT_Ptr, Loc)), + Make_Identifier (Loc, Name_uS))))); + + if Ekind (Conc_Typ) = E_Protected_Type then + + -- Generate: + -- Protected_Entry_Call ( + -- T._object'access, + -- protected_entry_index! (I), + -- P, + -- Asynchronous_Call, + -- B); + + -- where T is the protected object, I is the entry index, P are + -- the wrapped parameters and B is the name of the communication + -- block. + + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Protected_Entry_Call), Loc), + Parameter_Associations => + New_List ( + + Make_Attribute_Reference (Loc, -- T._object'access + Attribute_Name => + Name_Unchecked_Access, + Prefix => + Make_Selected_Component (Loc, + Prefix => + Make_Identifier (Loc, Name_uT), + Selector_Name => + Make_Identifier (Loc, Name_uObject))), + + Make_Unchecked_Type_Conversion (Loc, -- entry index + Subtype_Mark => + New_Reference_To (RTE (RE_Protected_Entry_Index), Loc), + Expression => + Make_Identifier (Loc, Name_uI)), + + Make_Identifier (Loc, Name_uP), -- parameter block + New_Reference_To ( -- Asynchronous_Call + RTE (RE_Asynchronous_Call), Loc), + Make_Identifier (Loc, Name_uB)))); -- comm block + else + pragma Assert (Ekind (Conc_Typ) = E_Task_Type); + + -- Generate: + -- Protected_Entry_Call ( + -- T._task_id, + -- task_entry_index! (I), + -- P, + -- Conditional_Call, + -- F); + + -- where T is the task object, I is the entry index, P are the + -- wrapped parameters and F is the status flag. + + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Task_Entry_Call), Loc), + Parameter_Associations => + New_List ( + + Make_Selected_Component (Loc, -- T._task_id + Prefix => + Make_Identifier (Loc, Name_uT), + Selector_Name => + Make_Identifier (Loc, Name_uTask_Id)), + + Make_Unchecked_Type_Conversion (Loc, -- entry index + Subtype_Mark => + New_Reference_To (RTE (RE_Task_Entry_Index), Loc), + Expression => + Make_Identifier (Loc, Name_uI)), + + Make_Identifier (Loc, Name_uP), -- parameter block + New_Reference_To ( -- Asynchronous_Call + RTE (RE_Asynchronous_Call), Loc), + Make_Identifier (Loc, Name_uF)))); -- status flag + end if; + + -- Null implementation for limited tagged types + + else + Append_To (Stmts, + Make_Null_Statement (Loc)); + end if; + + return + Make_Subprogram_Body (Loc, + Specification => + Make_Disp_Asynchronous_Select_Spec (Typ), + Declarations => + Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, Stmts)); + end Make_Disp_Asynchronous_Select_Body; + + ---------------------------------------- + -- Make_Disp_Asynchronous_Select_Spec -- + ---------------------------------------- + + function Make_Disp_Asynchronous_Select_Spec + (Typ : Entity_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Typ); + Params : constant List_Id := New_List; + + begin + -- "T" - Object parameter + -- "S" - Primitive operation slot + -- "P" - Wrapped parameters + -- "B" - Communication block + -- "F" - Status flag + + SEU.Build_T (Loc, Typ, Params); + SEU.Build_S (Loc, Params); + SEU.Build_P (Loc, Params); + SEU.Build_B (Loc, Params); + SEU.Build_F (Loc, Params); + + return + Make_Procedure_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, Name_uDisp_Asynchronous_Select), + Parameter_Specifications => + Params); + end Make_Disp_Asynchronous_Select_Spec; + + --------------------------------------- + -- Make_Disp_Conditional_Select_Body -- + --------------------------------------- + + function Make_Disp_Conditional_Select_Body + (Typ : Entity_Id) return Node_Id + is + Blk_Nam : Entity_Id; + Conc_Typ : Entity_Id := Empty; + Decls : constant List_Id := New_List; + DT_Ptr : Entity_Id; + DT_Ptr_Typ : Entity_Id; + Loc : constant Source_Ptr := Sloc (Typ); + Stmts : constant List_Id := New_List; + + begin + if Is_Concurrent_Record_Type (Typ) then + Conc_Typ := Corresponding_Concurrent_Type (Typ); + end if; + + -- Typ may be a derived type, climb the derivation chain in order to + -- find the root. + + DT_Ptr_Typ := Typ; + while Present (Parent_Subtype (DT_Ptr_Typ)) loop + DT_Ptr_Typ := Parent_Subtype (DT_Ptr_Typ); + end loop; + + DT_Ptr := Node (First_Elmt (Access_Disp_Table (DT_Ptr_Typ))); + + if Present (Conc_Typ) then + -- Generate: + -- I : Integer; + + -- where I will be used to capture the entry index of the primitive + -- wrapper at position S. + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uI), + Object_Definition => + New_Reference_To (Standard_Integer, Loc))); + end if; + + -- Generate: + -- C := get_prim_op_kind (tag! (VP), S); + + -- if C = POK_Procedure + -- or else C = POK_Protected_Procedure + -- or else C = POK_Task_Procedure; + -- then + -- F := True; + -- return; + -- end if; + + SEU.Build_Common_Dispatching_Select_Statements (Loc, Typ, Stmts); + + if Present (Conc_Typ) then + + -- Generate: + -- Bnn : Communication_Block; + + -- where Bnn is the name of the communication block used in + -- the call to Protected_Entry_Call. + + Blk_Nam := Make_Defining_Identifier (Loc, New_Internal_Name ('B')); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + Blk_Nam, + Object_Definition => + New_Reference_To (RTE (RE_Communication_Block), Loc))); + + -- Generate: + -- I := get_entry_index (tag! (VP), S); + + -- where I is the entry index and S is the dispatch table slot. + + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => + Make_Identifier (Loc, Name_uI), + Expression => + Make_DT_Access_Action (Typ, + Action => + Get_Entry_Index, + Args => + New_List ( + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (DT_Ptr, Loc)), + Make_Identifier (Loc, Name_uS))))); + + if Ekind (Conc_Typ) = E_Protected_Type then + + -- Generate: + -- Protected_Entry_Call ( + -- T._object'access, + -- protected_entry_index! (I), + -- P, + -- Conditional_Call, + -- Bnn); + + -- where T is the protected object, I is the entry index, P are + -- the wrapped parameters and Bnn is the name of the communication + -- block. + + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Protected_Entry_Call), Loc), + Parameter_Associations => + New_List ( + + Make_Attribute_Reference (Loc, -- T._object'access + Attribute_Name => + Name_Unchecked_Access, + Prefix => + Make_Selected_Component (Loc, + Prefix => + Make_Identifier (Loc, Name_uT), + Selector_Name => + Make_Identifier (Loc, Name_uObject))), + + Make_Unchecked_Type_Conversion (Loc, -- entry index + Subtype_Mark => + New_Reference_To (RTE (RE_Protected_Entry_Index), Loc), + Expression => + Make_Identifier (Loc, Name_uI)), + + Make_Identifier (Loc, Name_uP), -- parameter block + New_Reference_To ( -- Conditional_Call + RTE (RE_Conditional_Call), Loc), + New_Reference_To ( -- Bnn + Blk_Nam, Loc)))); + + -- Generate: + -- F := not Cancelled (Bnn); + + -- where F is the success flag. The status of Cancelled is negated + -- in order to match the behaviour of the version for task types. + + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => + Make_Identifier (Loc, Name_uF), + Expression => + Make_Op_Not (Loc, + Right_Opnd => + Make_Function_Call (Loc, + Name => + New_Reference_To (RTE (RE_Cancelled), Loc), + Parameter_Associations => + New_List ( + New_Reference_To (Blk_Nam, Loc)))))); + else + pragma Assert (Ekind (Conc_Typ) = E_Task_Type); + + -- Generate: + -- Protected_Entry_Call ( + -- T._task_id, + -- task_entry_index! (I), + -- P, + -- Conditional_Call, + -- F); + + -- where T is the task object, I is the entry index, P are the + -- wrapped parameters and F is the status flag. + + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Task_Entry_Call), Loc), + Parameter_Associations => + New_List ( + + Make_Selected_Component (Loc, -- T._task_id + Prefix => + Make_Identifier (Loc, Name_uT), + Selector_Name => + Make_Identifier (Loc, Name_uTask_Id)), + + Make_Unchecked_Type_Conversion (Loc, -- entry index + Subtype_Mark => + New_Reference_To (RTE (RE_Task_Entry_Index), Loc), + Expression => + Make_Identifier (Loc, Name_uI)), + + Make_Identifier (Loc, Name_uP), -- parameter block + New_Reference_To ( -- Conditional_Call + RTE (RE_Conditional_Call), Loc), + Make_Identifier (Loc, Name_uF)))); -- status flag + end if; + + -- Null implementation for limited tagged types + + else + Append_To (Stmts, + Make_Null_Statement (Loc)); + end if; + + return + Make_Subprogram_Body (Loc, + Specification => + Make_Disp_Conditional_Select_Spec (Typ), + Declarations => + Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, Stmts)); + end Make_Disp_Conditional_Select_Body; + + --------------------------------------- + -- Make_Disp_Conditional_Select_Spec -- + --------------------------------------- + + function Make_Disp_Conditional_Select_Spec + (Typ : Entity_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Typ); + Params : constant List_Id := New_List; + + begin + -- "T" - Object parameter + -- "S" - Primitive operation slot + -- "P" - Wrapped parameters + -- "C" - Call kind + -- "F" - Status flag + + SEU.Build_T (Loc, Typ, Params); + SEU.Build_S (Loc, Params); + SEU.Build_P (Loc, Params); + SEU.Build_C (Loc, Params); + SEU.Build_F (Loc, Params); + + return + Make_Procedure_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, Name_uDisp_Conditional_Select), + Parameter_Specifications => + Params); + end Make_Disp_Conditional_Select_Spec; + + ------------------------------------- + -- Make_Disp_Get_Prim_Op_Kind_Body -- + ------------------------------------- + + function Make_Disp_Get_Prim_Op_Kind_Body + (Typ : Entity_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Typ); + DT_Ptr : Entity_Id; + DT_Ptr_Typ : Entity_Id; + + begin + -- Typ may be a derived type, climb the derivation chain in order to + -- find the root. + + DT_Ptr_Typ := Typ; + while Present (Parent_Subtype (DT_Ptr_Typ)) loop + DT_Ptr_Typ := Parent_Subtype (DT_Ptr_Typ); + end loop; + + DT_Ptr := Node (First_Elmt (Access_Disp_Table (DT_Ptr_Typ))); + + -- Generate: + -- C := get_prim_op_kind (tag! (VP), S); + + -- where C is the out parameter capturing the call kind and S is the + -- dispatch table slot number. + + return + Make_Subprogram_Body (Loc, + Specification => + Make_Disp_Get_Prim_Op_Kind_Spec (Typ), + Declarations => + No_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + New_List ( + Make_Assignment_Statement (Loc, + Name => + Make_Identifier (Loc, Name_uC), + Expression => + Make_DT_Access_Action (Typ, + Action => + Get_Prim_Op_Kind, + Args => + New_List ( + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (DT_Ptr, Loc)), + Make_Identifier (Loc, Name_uS))))))); + end Make_Disp_Get_Prim_Op_Kind_Body; + + ------------------------------------- + -- Make_Disp_Get_Prim_Op_Kind_Spec -- + ------------------------------------- + + function Make_Disp_Get_Prim_Op_Kind_Spec + (Typ : Entity_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Typ); + Params : constant List_Id := New_List; + + begin + -- "T" - Object parameter + -- "S" - Primitive operation slot + -- "C" - Call kind + + SEU.Build_T (Loc, Typ, Params); + SEU.Build_S (Loc, Params); + SEU.Build_C (Loc, Params); + + return + Make_Procedure_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, Name_uDisp_Get_Prim_Op_Kind), + Parameter_Specifications => + Params); + end Make_Disp_Get_Prim_Op_Kind_Spec; + + ----------------------------- + -- Make_Disp_Select_Tables -- + ----------------------------- + + function Make_Disp_Select_Tables + (Typ : Entity_Id) return List_Id + is + Assignments : constant List_Id := New_List; + DT_Ptr : Entity_Id; + DT_Ptr_Typ : Entity_Id; + Index : Uint := Uint_1; + Loc : constant Source_Ptr := Sloc (Typ); + Prim : Entity_Id; + Prim_Als : Entity_Id; + Prim_Elmt : Elmt_Id; + Prim_Pos : Uint; + + begin + pragma Assert (Present (Primitive_Operations (Typ))); + + -- Typ may be a derived type, climb the derivation chain in order to + -- find the root. + + DT_Ptr_Typ := Typ; + while Present (Parent_Subtype (DT_Ptr_Typ)) loop + DT_Ptr_Typ := Parent_Subtype (DT_Ptr_Typ); + end loop; + + DT_Ptr := Node (First_Elmt (Access_Disp_Table (DT_Ptr_Typ))); + + Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + + -- Retrieve the root of the alias chain + + if Present (Alias (Prim)) then + Prim_Als := Prim; + while Present (Alias (Prim_Als)) loop + Prim_Als := Alias (Prim_Als); + end loop; + else + Prim_Als := Empty; + end if; + + -- We either have a procedure or a wrapper. Set the primitive + -- operation kind for both cases and set the entry index for + -- wrappers. + + if Ekind (Prim) = E_Procedure + and then Present (Prim_Als) + and then Is_Primitive_Wrapper (Prim_Als) + then + Prim_Pos := DT_Position (Prim); + + -- Generate: + -- set_prim_op_kind (, , ); + + Append_To (Assignments, + Make_DT_Access_Action (Typ, + Action => + Set_Prim_Op_Kind, + Args => + New_List ( + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (DT_Ptr, Loc)), + Make_Integer_Literal (Loc, Prim_Pos), + Prim_Op_Kind (Prim, Typ)))); + + -- The wrapped entity of the alias is an entry + + if Ekind (Wrapped_Entity (Prim_Als)) = E_Entry then + -- Generate: + -- set_entry_index (, , ); + + Append_To (Assignments, + Make_DT_Access_Action (Typ, + Action => + Set_Entry_Index, + Args => + New_List ( + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (DT_Ptr, Loc)), + Make_Integer_Literal (Loc, Prim_Pos), + Make_Integer_Literal (Loc, Index)))); + + Index := Index + 1; + end if; + end if; + + Next_Elmt (Prim_Elmt); + end loop; + + return Assignments; + end Make_Disp_Select_Tables; + + --------------------------------- + -- Make_Disp_Timed_Select_Body -- + --------------------------------- + + function Make_Disp_Timed_Select_Body + (Typ : Entity_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Typ); + Conc_Typ : Entity_Id := Empty; + Decls : constant List_Id := New_List; + DT_Ptr : Entity_Id; + DT_Ptr_Typ : Entity_Id; + Stmts : constant List_Id := New_List; + + begin + if Is_Concurrent_Record_Type (Typ) then + Conc_Typ := Corresponding_Concurrent_Type (Typ); + end if; + + -- Typ may be a derived type, climb the derivation chain in order to + -- find the root. + + DT_Ptr_Typ := Typ; + while Present (Parent_Subtype (DT_Ptr_Typ)) loop + DT_Ptr_Typ := Parent_Subtype (DT_Ptr_Typ); + end loop; + + DT_Ptr := Node (First_Elmt (Access_Disp_Table (DT_Ptr_Typ))); + + if Present (Conc_Typ) then + + -- Generate: + -- I : Integer; + + -- where I will be used to capture the entry index of the primitive + -- wrapper at position S. + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uI), + Object_Definition => + New_Reference_To (Standard_Integer, Loc))); + end if; + + -- Generate: + -- C := get_prim_op_kind (tag! (VP), S); + + -- if C = POK_Procedure + -- or else C = POK_Protected_Procedure + -- or else C = POK_Task_Procedure; + -- then + -- F := True; + -- return; + -- end if; + + SEU.Build_Common_Dispatching_Select_Statements (Loc, Typ, Stmts); + + if Present (Conc_Typ) then + + -- Generate: + -- I := get_entry_index (tag! (VP), S); + + -- where I is the entry index and S is the dispatch table slot. + + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => + Make_Identifier (Loc, Name_uI), + Expression => + Make_DT_Access_Action (Typ, + Action => + Get_Entry_Index, + Args => + New_List ( + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (DT_Ptr, Loc)), + Make_Identifier (Loc, Name_uS))))); + + if Ekind (Conc_Typ) = E_Protected_Type then + + -- Generate: + -- Timed_Protected_Entry_Call ( + -- T._object'access, + -- protected_entry_index! (I), + -- P, + -- D, + -- M, + -- F); + + -- where T is the protected object, I is the entry index, P are + -- the wrapped parameters, D is the delay amount, M is the delay + -- mode and F is the status flag. + + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Timed_Protected_Entry_Call), Loc), + Parameter_Associations => + New_List ( + + Make_Attribute_Reference (Loc, -- T._object'access + Attribute_Name => + Name_Unchecked_Access, + Prefix => + Make_Selected_Component (Loc, + Prefix => + Make_Identifier (Loc, Name_uT), + Selector_Name => + Make_Identifier (Loc, Name_uObject))), + + Make_Unchecked_Type_Conversion (Loc, -- entry index + Subtype_Mark => + New_Reference_To (RTE (RE_Protected_Entry_Index), Loc), + Expression => + Make_Identifier (Loc, Name_uI)), + + Make_Identifier (Loc, Name_uP), -- parameter block + Make_Identifier (Loc, Name_uD), -- delay + Make_Identifier (Loc, Name_uM), -- delay mode + Make_Identifier (Loc, Name_uF)))); -- status flag + + else + pragma Assert (Ekind (Conc_Typ) = E_Task_Type); + + -- Generate: + -- Timed_Task_Entry_Call ( + -- T._task_id, + -- task_entry_index! (I), + -- P, + -- D, + -- M, + -- F); + + -- where T is the task object, I is the entry index, P are the + -- wrapped parameters, D is the delay amount, M is the delay + -- mode and F is the status flag. + + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Timed_Task_Entry_Call), Loc), + Parameter_Associations => + New_List ( + + Make_Selected_Component (Loc, -- T._task_id + Prefix => + Make_Identifier (Loc, Name_uT), + Selector_Name => + Make_Identifier (Loc, Name_uTask_Id)), + + Make_Unchecked_Type_Conversion (Loc, -- entry index + Subtype_Mark => + New_Reference_To (RTE (RE_Task_Entry_Index), Loc), + Expression => + Make_Identifier (Loc, Name_uI)), + + Make_Identifier (Loc, Name_uP), -- parameter block + Make_Identifier (Loc, Name_uD), -- delay + Make_Identifier (Loc, Name_uM), -- delay mode + Make_Identifier (Loc, Name_uF)))); -- status flag + end if; + + -- Null implementation for limited tagged types + + else + Append_To (Stmts, + Make_Null_Statement (Loc)); + end if; + + return + Make_Subprogram_Body (Loc, + Specification => + Make_Disp_Timed_Select_Spec (Typ), + Declarations => + Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, Stmts)); + end Make_Disp_Timed_Select_Body; + + --------------------------------- + -- Make_Disp_Timed_Select_Spec -- + --------------------------------- + + function Make_Disp_Timed_Select_Spec + (Typ : Entity_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Typ); + Params : constant List_Id := New_List; + + begin + -- "T" - Object parameter + -- "S" - Primitive operation slot + -- "P" - Wrapped parameters + -- "D" - Delay + -- "M" - Delay Mode + -- "C" - Call kind + -- "F" - Status flag + + SEU.Build_T (Loc, Typ, Params); + SEU.Build_S (Loc, Params); + SEU.Build_P (Loc, Params); + + Append_To (Params, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uD), + Parameter_Type => + New_Reference_To (Standard_Duration, Loc))); + + Append_To (Params, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uM), + Parameter_Type => + New_Reference_To (Standard_Integer, Loc))); + + SEU.Build_C (Loc, Params); + SEU.Build_F (Loc, Params); + + return + Make_Procedure_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, Name_uDisp_Timed_Select), + Parameter_Specifications => + Params); + end Make_Disp_Timed_Select_Spec; + ----------------------------------- -- Original_View_In_Visible_Part -- ----------------------------------- @@ -1989,6 +3310,86 @@ package body Exp_Disp is Visible_Declarations (Specification (Unit_Declaration_Node (Scop))); end Original_View_In_Visible_Part; + ------------------ + -- Prim_Op_Kind -- + ------------------ + + function Prim_Op_Kind + (Prim : Entity_Id; + Typ : Entity_Id) return Node_Id + is + Full_Typ : Entity_Id := Typ; + Loc : constant Source_Ptr := Sloc (Prim); + Prim_Op : Entity_Id := Prim; + + begin + -- Retrieve the original primitive operation + + while Present (Alias (Prim_Op)) loop + Prim_Op := Alias (Prim_Op); + end loop; + + if Ekind (Typ) = E_Record_Type + and then Present (Corresponding_Concurrent_Type (Typ)) + then + Full_Typ := Corresponding_Concurrent_Type (Typ); + end if; + + if Ekind (Prim_Op) = E_Function then + + -- Protected function + + if Ekind (Full_Typ) = E_Protected_Type then + return New_Reference_To (RTE (RE_POK_Protected_Function), Loc); + + -- Regular function + + else + return New_Reference_To (RTE (RE_POK_Function), Loc); + end if; + + else + pragma Assert (Ekind (Prim_Op) = E_Procedure); + + if Ekind (Full_Typ) = E_Protected_Type then + + -- Protected entry + + if Is_Primitive_Wrapper (Prim_Op) + and then Ekind (Wrapped_Entity (Prim_Op)) = E_Entry + then + return New_Reference_To (RTE (RE_POK_Protected_Entry), Loc); + + -- Protected procedure + + else + return New_Reference_To (RTE (RE_POK_Protected_Procedure), Loc); + end if; + + elsif Ekind (Full_Typ) = E_Task_Type then + + -- Task entry + + if Is_Primitive_Wrapper (Prim_Op) + and then Ekind (Wrapped_Entity (Prim_Op)) = E_Entry + then + return New_Reference_To (RTE (RE_POK_Task_Entry), Loc); + + -- Task "procedure". These are the internally Expander-generated + -- procedures (task body for instance). + + else + return New_Reference_To (RTE (RE_POK_Task_Procedure), Loc); + end if; + + -- Regular procedure + + else + return New_Reference_To (RTE (RE_POK_Procedure), Loc); + end if; + end if; + end Prim_Op_Kind; + ------------------------- -- Set_All_DT_Position -- ------------------------- @@ -2020,6 +3421,7 @@ package body Exp_Disp is procedure Validate_Position (Prim : Entity_Id) is Prim_Elmt : Elmt_Id; + begin Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); while Present (Prim_Elmt) @@ -2043,7 +3445,40 @@ package body Exp_Disp is null; elsif DT_Position (Node (Prim_Elmt)) = DT_Position (Prim) then - raise Program_Error; + + -- Handle aliased subprograms + + declare + Op_1 : Entity_Id; + Op_2 : Entity_Id; + + begin + Op_1 := Node (Prim_Elmt); + loop + if Present (Overridden_Operation (Op_1)) then + Op_1 := Overridden_Operation (Op_1); + elsif Present (Alias (Op_1)) then + Op_1 := Alias (Op_1); + else + exit; + end if; + end loop; + + Op_2 := Prim; + loop + if Present (Overridden_Operation (Op_2)) then + Op_2 := Overridden_Operation (Op_2); + elsif Present (Alias (Op_2)) then + Op_2 := Alias (Op_2); + else + exit; + end if; + end loop; + + if Op_1 /= Op_2 then + raise Program_Error; + end if; + end; end if; Next_Elmt (Prim_Elmt); @@ -2096,9 +3531,10 @@ package body Exp_Disp is -- Get the slot from the parent subprogram if any declare - H : Entity_Id := Homonym (Prim); + H : Entity_Id; begin + H := Homonym (Prim); while Present (H) loop if Present (DTC_Entity (H)) and then Root_Type (Scope (DTC_Entity (H))) = Root_Typ @@ -2129,7 +3565,7 @@ package body Exp_Disp is -- Check that the declared size of the Vtable is bigger or equal -- than the number of primitive operations (if bigger it means that -- some of the c++ virtual functions were not imported, that is - -- allowed) + -- allowed). if DT_Entry_Count (The_Tag) = No_Uint or else not Is_CPP_Class (Typ) @@ -2142,7 +3578,7 @@ package body Exp_Disp is end if; -- Check that Positions are not duplicate nor outside the range of - -- the Vtable + -- the Vtable. declare Size : constant Int := UI_To_Int (DT_Entry_Count (The_Tag)); @@ -2175,13 +3611,19 @@ package body Exp_Disp is end loop; end; + -- Generate listing showing the contents of the dispatch tables + + if Debug_Flag_ZZ then + Write_DT (Typ); + end if; + -- For regular Ada tagged types, just set the DT_Position for -- each primitive operation. Perform some sanity checks to avoid -- to build completely inconsistant dispatch tables. -- Note that the _Size primitive is always set at position 1 in order -- to comply with the needs of Ada.Tags.Parent_Size (see documentation - -- in a-tags.ad?) + -- in Ada.Tags). else -- First stage: Set the DTC entity of all the primitive operations @@ -2190,7 +3632,6 @@ package body Exp_Disp is Prim_Elmt := First_Prim; Count_Prim := 0; - while Present (Prim_Elmt) loop Count_Prim := Count_Prim + 1; Prim := Node (Prim_Elmt); @@ -2218,16 +3659,17 @@ package body Exp_Disp is end loop; declare - Fixed_Prim : array (Int range 0 .. 10 + Parent_EC + Count_Prim) - of Boolean := (others => False); - E : Entity_Id; + Fixed_Prim : array (Int range 0 .. Default_Prim_Op_Count + + Parent_EC + Count_Prim) + of Boolean := (others => False); + + E : Entity_Id; begin -- Second stage: Register fixed entries - Nb_Prim := 10; + Nb_Prim := Default_Prim_Op_Count; Prim_Elmt := First_Prim; - while Present (Prim_Elmt) loop Prim := Node (Prim_Elmt); @@ -2287,12 +3729,10 @@ package body Exp_Disp is -- traversing the chain. This is required to properly -- handling renamed primitives - if Present (Alias (E)) then - while Present (Alias (E)) loop - E := Alias (E); - Fixed_Prim (UI_To_Int (DT_Position (E))) := True; - end loop; - end if; + while Present (Alias (E)) loop + E := Alias (E); + Fixed_Prim (UI_To_Int (DT_Position (E))) := True; + end loop; end if; Next_Elmt (Prim_Elmt); @@ -2369,12 +3809,20 @@ package body Exp_Disp is Next_Elmt (Prim_Elmt); end loop; + -- Generate listing showing the contents of the dispatch tables. + -- This action is done before some further static checks because + -- in case of critical errors caused by a wrong dispatch table + -- we need to see the contents of such table. + + if Debug_Flag_ZZ then + Write_DT (Typ); + end if; + -- Final stage: Ensure that the table is correct plus some further -- verifications concerning the primitives. Prim_Elmt := First_Prim; DT_Length := 0; - while Present (Prim_Elmt) loop Prim := Node (Prim_Elmt); @@ -2473,10 +3921,6 @@ package body Exp_Disp is null; end if; end if; - - if Debug_Flag_ZZ then - Write_DT (Typ); - end if; end Set_All_DT_Position; ----------------------------- @@ -2546,7 +3990,7 @@ package body Exp_Disp is if not (Typ in First_Node_Id .. Last_Node_Id) or else not Is_Tagged_Type (Typ) then - Write_Str ("wrong usage: write_dt must be used with tagged types"); + Write_Str ("wrong usage: Write_DT must be used with tagged types"); Write_Eol; return; end if; diff --git a/gcc/ada/exp_disp.ads b/gcc/ada/exp_disp.ads index 10900d0..469ea79 100644 --- a/gcc/ada/exp_disp.ads +++ b/gcc/ada/exp_disp.ads @@ -30,14 +30,26 @@ with Types; use Types; package Exp_Disp is + -- Number of predefined primitive operations added by the Expander + -- for a tagged type. If more predefined primitive operations are + -- added, the following items must be changed: + + -- Ada.Tags.Defailt_Prim_Op_Count - indirect use + -- Exp_Disp.Default_Prim_Op_Position - indirect use + -- Exp_Disp.Set_All_DT_Position - direct use + + Default_Prim_Op_Count : constant Int := 14; + type DT_Access_Action is (CW_Membership, IW_Membership, DT_Entry_Size, DT_Prologue_Size, Get_Access_Level, + Get_Entry_Index, Get_External_Tag, Get_Prim_Op_Address, + Get_Prim_Op_Kind, Get_RC_Offset, Get_Remotely_Callable, Inherit_DT, @@ -45,15 +57,42 @@ package Exp_Disp is Register_Interface_Tag, Register_Tag, Set_Access_Level, + Set_Entry_Index, Set_Expanded_Name, Set_External_Tag, Set_Prim_Op_Address, + Set_Prim_Op_Kind, Set_RC_Offset, Set_Remotely_Callable, Set_TSD, TSD_Entry_Size, TSD_Prologue_Size); + procedure Expand_Dispatching_Call (Call_Node : Node_Id); + -- Expand the call to the operation through the dispatch table and perform + -- the required tag checks when appropriate. For CPP types the call is + -- done through the Vtable (tag checks are not relevant) + + procedure Expand_Interface_Actuals (Call_Node : Node_Id); + -- Ada 2005 (AI-251): Displace all the actuals corresponding to class-wide + -- interfaces to reference the interface tag of the actual object + + procedure Expand_Interface_Conversion (N : Node_Id); + -- Ada 2005 (AI-251): N is a type-conversion node. Reference the base of + -- the object to give access to the interface tag associated with the + -- secondary dispatch table + + function Expand_Interface_Thunk + (N : Node_Id; + Thunk_Alias : Node_Id; + Thunk_Id : Entity_Id; + Thunk_Tag : Entity_Id) return Node_Id; + -- Ada 2005 (AI-251): When a tagged type implements abstract interfaces we + -- generate additional subprograms (thunks) to have a layout compatible + -- with the C++ ABI. The thunk modifies the value of the first actual of + -- the call (that is, the pointer to the object) before transferring + -- control to the target function. + function Fill_DT_Entry (Loc : Source_Ptr; Prim : Entity_Id) return Node_Id; @@ -69,6 +108,15 @@ package Exp_Disp is -- the secondary dispatch table of Prim's controlling type with Thunk_Id's -- address. + function Get_Remotely_Callable (Obj : Node_Id) return Node_Id; + -- Return an expression that holds True if the object can be transmitted + -- onto another partition according to E.4 (18) + + function Init_Predefined_Interface_Primitives + (Typ : Entity_Id) return List_Id; + -- Ada 2005 (AI-251): Initialize the entries associated with predefined + -- primitives in all the secondary dispatch tables of Typ. + procedure Make_Abstract_Interface_DT (AI_Tag : Entity_Id; Acc_Disp_Tables : in out Elist_Id; @@ -90,45 +138,65 @@ package Exp_Disp is -- Expand the declarations for the Dispatch Table (or the Vtable in -- the case of type whose ancestor is a CPP_Class) + function Make_Disp_Asynchronous_Select_Body + (Typ : Entity_Id) return Node_Id; + -- Ada 2005 (AI-345): Generate the body of the primitive operation of type + -- Typ used for dispatching in asynchronous selects. + + function Make_Disp_Asynchronous_Select_Spec + (Typ : Entity_Id) return Node_Id; + -- Ada 2005 (AI-345): Generate the specification of the primitive operation + -- of type Typ used for dispatching in asynchronous selects. + + function Make_Disp_Conditional_Select_Body + (Typ : Entity_Id) return Node_Id; + -- Ada 2005 (AI-345): Generate the body of the primitive operation of type + -- Typ used for dispatching in conditional selects. + + function Make_Disp_Conditional_Select_Spec + (Typ : Entity_Id) return Node_Id; + -- Ada 2005 (AI-345): Generate the specification of the primitive operation + -- of type Typ used for dispatching in conditional selects. + + function Make_Disp_Get_Prim_Op_Kind_Body + (Typ : Entity_Id) return Node_Id; + -- Ada 2005 (AI-345): Generate the body of the primitive operation of type + -- Typ used for retrieving the callable entity kind during dispatching in + -- asynchronous selects. + + function Make_Disp_Get_Prim_Op_Kind_Spec + (Typ : Entity_Id) return Node_Id; + -- Ada 2005 (AI-345): Generate the specification of the primitive operation + -- of the type Typ use for retrieving the callable entity kind during + -- dispatching in asynchronous selects. + + function Make_Disp_Select_Tables + (Typ : Entity_Id) return List_Id; + -- Ada 2005 (AI-345): Populate the two auxiliary tables in the TSD of Typ + -- used for dispatching in asynchronous, conditional and timed selects. + -- Generate code to set the primitive operation kinds and entry indices + -- of primitive operations and primitive wrappers. + + function Make_Disp_Timed_Select_Body + (Typ : Entity_Id) return Node_Id; + -- Ada 2005 (AI-345): Generate the body of the primitive operation of type + -- Typ used for dispatching in timed selects. + + function Make_Disp_Timed_Select_Spec + (Typ : Entity_Id) return Node_Id; + -- Ada 2005 (AI-345): Generate the specification of the primitive operation + -- of type Typ used for dispatching in timed selects. + procedure Set_All_DT_Position (Typ : Entity_Id); -- Set the DT_Position field for each primitive operation. In the CPP -- Class case check that no pragma CPP_Virtual is missing and that the -- DT_Position are coherent - procedure Expand_Dispatching_Call (Call_Node : Node_Id); - -- Expand the call to the operation through the dispatch table and perform - -- the required tag checks when appropriate. For CPP types the call is - -- done through the Vtable (tag checks are not relevant) - - procedure Expand_Interface_Actuals (Call_Node : Node_Id); - -- Ada 2005 (AI-251): Displace all the actuals corresponding to class-wide - -- interfaces to reference the interface tag of the actual object - - procedure Expand_Interface_Conversion (N : Node_Id); - -- Ada 2005 (AI-251): N is a type-conversion node. Reference the base of - -- the object to give access to the interface tag associated with the - -- secondary dispatch table - - function Expand_Interface_Thunk - (N : Node_Id; - Thunk_Alias : Node_Id; - Thunk_Id : Entity_Id; - Iface_Tag : Entity_Id) return Node_Id; - -- Ada 2005 (AI-251): When a tagged type implements abstract interfaces we - -- generate additional subprograms (thunks) to have a layout compatible - -- with the C++ ABI. The thunk modifies the value of the first actual of - -- the call (that is, the pointer to the object) before transferring - -- control to the target function. - procedure Set_Default_Constructor (Typ : Entity_Id); -- Typ is a CPP_Class type. Create the Init procedure of that type to -- be the default constructor (i.e. the function returning this type, -- having a pragma CPP_Constructor and no parameter) - function Get_Remotely_Callable (Obj : Node_Id) return Node_Id; - -- Return an expression that holds True if the object can be transmitted - -- onto another partition according to E.4 (18) - procedure Write_DT (Typ : Entity_Id); pragma Export (Ada, Write_DT); -- Debugging procedure (to be called within gdb) diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 643ed8a..ebef01d 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -31,8 +31,6 @@ with Elists; use Elists; with Errout; use Errout; with Exp_Aggr; use Exp_Aggr; with Exp_Ch7; use Exp_Ch7; -with Exp_Ch11; use Exp_Ch11; -with Exp_Tss; use Exp_Tss; with Hostparm; use Hostparm; with Inline; use Inline; with Itypes; use Itypes; @@ -49,7 +47,6 @@ with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Type; use Sem_Type; with Sem_Util; use Sem_Util; -with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; @@ -685,7 +682,7 @@ package body Exp_Util is Spec := Make_Function_Specification (Loc, Defining_Unit_Name => Make_Defining_Identifier (Loc, New_Internal_Name ('F')), - Subtype_Mark => New_Occurrence_Of (Standard_String, Loc)); + Result_Definition => New_Occurrence_Of (Standard_String, Loc)); -- Calls to 'Image use the secondary stack, which must be cleaned -- up after the task name is built. @@ -1278,6 +1275,13 @@ package body Exp_Util is then null; + -- Nothing to be done if the type of the expression is limited, because + -- in this case the expression cannot be copied, and its use can only + -- be by reference and there is no need for the actual subtype. + + elsif Is_Limited_Type (Exp_Typ) then + null; + else Remove_Side_Effects (Exp); Rewrite (Subtype_Indic, @@ -1409,7 +1413,7 @@ package body Exp_Util is and then Present (Abstract_Interfaces (Typ)) and then not (Is_Empty_Elmt_List (Abstract_Interfaces (Typ))) then - -- Skip the tag associated with the primary table. + -- Skip the tag associated with the primary table pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag)); AI_Tag := Next_Tag_Component (First_Tag_Component (Typ)); @@ -1449,12 +1453,21 @@ package body Exp_Util is -- Handle task and protected types implementing interfaces - if Ekind (Typ) = E_Protected_Type - or else Ekind (Typ) = E_Task_Type - then + if Is_Concurrent_Type (Typ) then Typ := Corresponding_Record_Type (Typ); end if; + if Is_Class_Wide_Type (Typ) then + Typ := Etype (Typ); + end if; + + -- Handle entities from the limited view + + if Ekind (Typ) = E_Incomplete_Type then + pragma Assert (Present (Non_Limited_View (Typ))); + Typ := Non_Limited_View (Typ); + end if; + Find_Tag (Typ); pragma Assert (Found); return AI_Tag; @@ -1729,6 +1742,68 @@ package body Exp_Util is return Count; end Homonym_Number; + ---------------------------------- + -- Implements_Limited_Interface -- + ---------------------------------- + + function Implements_Limited_Interface (Typ : Entity_Id) return Boolean is + function Contains_Limited_Interface + (Ifaces : Elist_Id) return Boolean; + -- Given a list of interfaces, determine whether one of them is limited + + -------------------------------- + -- Contains_Limited_Interface -- + -------------------------------- + + function Contains_Limited_Interface + (Ifaces : Elist_Id) return Boolean + is + Iface_Elmt : Elmt_Id; + + begin + if not Present (Ifaces) then + return False; + end if; + + Iface_Elmt := First_Elmt (Ifaces); + + while Present (Iface_Elmt) loop + if Is_Limited_Record (Node (Iface_Elmt)) then + return True; + end if; + + Iface_Elmt := Next_Elmt (Iface_Elmt); + end loop; + + return False; + end Contains_Limited_Interface; + + -- Start of processing for Implements_Limited_Interface + + begin + -- Typ is a derived type and may implement a limited interface + -- through its parent subtype. Check the parent subtype as well + -- as any interfaces explicitly implemented at this level. + + if Ekind (Typ) = E_Record_Type + and then Present (Parent_Subtype (Typ)) + then + return Contains_Limited_Interface (Abstract_Interfaces (Typ)) + or else Implements_Limited_Interface (Parent_Subtype (Typ)); + + -- Typ is an abstract type derived from some interface + + elsif Is_Abstract (Typ) then + return Is_Interface (Etype (Typ)) + and then Is_Limited_Record (Etype (Typ)); + + -- Typ may directly implement some interface + + else + return Contains_Limited_Interface (Abstract_Interfaces (Typ)); + end if; + end Implements_Limited_Interface; + ------------------------------ -- In_Unconditional_Context -- ------------------------------ @@ -2515,6 +2590,10 @@ package body Exp_Util is or else Chars (E) = Name_uAssign or else TSS_Name = TSS_Deep_Adjust or else TSS_Name = TSS_Deep_Finalize + or else Chars (E) = Name_uDisp_Asynchronous_Select + or else Chars (E) = Name_uDisp_Conditional_Select + or else Chars (E) = Name_uDisp_Get_Prim_Op_Kind + or else Chars (E) = Name_uDisp_Timed_Select then return True; end if; @@ -2919,7 +2998,6 @@ package body Exp_Util is procedure Kill_Dead_Code (N : Node_Id) is begin if Present (N) then - Remove_Handler_Entries (N); Remove_Warning_Messages (N); -- Recurse into block statements and bodies to process declarations diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index e6ad240..a63cc71 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -410,6 +410,12 @@ package Exp_Util is -- chain, counting only entries in the curren scope. If an entity is not -- overloaded, the returned number will be one. + function Implements_Limited_Interface (Typ : Entity_Id) return Boolean; + -- Ada 2005 (AI-345): Determine whether Typ implements some limited + -- interface. The interface may be of limited, protected, synchronized + -- or taks kind. Typ may also be derived from a type that implements a + -- limited interface. + function Inside_Init_Proc return Boolean; -- Returns True if current scope is within an init proc diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 5c0f877..07adc39 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -108,7 +108,7 @@ package Rtsfind is -- package see declarations in the runtime entity table below. RTU_Null, - -- Used as a null entry. Will cause an error if referenced. + -- Used as a null entry. Will cause an error if referenced -- Children of Ada @@ -199,7 +199,6 @@ package Rtsfind is System_Compare_Array_Unsigned_64, System_Compare_Array_Unsigned_8, System_Exception_Table, - System_Exceptions, System_Exn_Int, System_Exn_LLF, System_Exn_LLI, @@ -492,21 +491,33 @@ package Rtsfind is RE_DT_Prologue_Size, -- Ada.Tags RE_External_Tag, -- Ada.Tags RE_Get_Access_Level, -- Ada.Tags + RE_Get_Entry_Index, -- Ada.Tags RE_Get_External_Tag, -- Ada.Tags RE_Get_Prim_Op_Address, -- Ada.Tags + RE_Get_Prim_Op_Kind, -- Ada.Tags RE_Get_RC_Offset, -- Ada.Tags RE_Get_Remotely_Callable, -- Ada.Tags RE_Inherit_DT, -- Ada.Tags RE_Inherit_TSD, -- Ada.Tags RE_Internal_Tag, -- Ada.Tags RE_Is_Descendant_At_Same_Level, -- Ada.Tags + RE_POK_Function, -- Ada.Tags + RE_POK_Procedure, -- Ada.Tags + RE_POK_Protected_Entry, -- Ada.Tags + RE_POK_Protected_Function, -- Ada.Tags + RE_POK_Protected_Procedure, -- Ada.Tags + RE_POK_Task_Entry, -- Ada.Tags + RE_POK_Task_Procedure, -- Ada.Tags + RE_Prim_Op_Kind, -- Ada.Tags RE_Register_Interface_Tag, -- Ada.Tags RE_Register_Tag, -- Ada.Tags RE_Set_Access_Level, -- Ada.Tags + RE_Set_Entry_Index, -- Ada.Tags RE_Set_Expanded_Name, -- Ada.Tags RE_Set_External_Tag, -- Ada.Tags RE_Set_Offset_To_Top, -- Ada.Tags RE_Set_Prim_Op_Address, -- Ada.Tags + RE_Set_Prim_Op_Kind, -- Ada.Tags RE_Set_RC_Offset, -- Ada.Tags RE_Set_Remotely_Callable, -- Ada.Tags RE_Set_TSD, -- Ada.Tags @@ -639,20 +650,6 @@ package Rtsfind is RE_Register_Exception, -- System.Exception_Table - RE_All_Others_Id, -- System.Exceptions - RE_Handler_Record, -- System.Exceptions - RE_Handler_Record_Ptr, -- System.Exceptions - RE_Others_Id, -- System.Exceptions - RE_Subprogram_Descriptor, -- System.Exceptions - RE_Subprogram_Descriptor_0, -- System.Exceptions - RE_Subprogram_Descriptor_1, -- System.Exceptions - RE_Subprogram_Descriptor_2, -- System.Exceptions - RE_Subprogram_Descriptor_3, -- System.Exceptions - RE_Subprogram_Descriptor_List, -- System.Exceptions - RE_Subprogram_Descriptor_Ptr, -- System.Exceptions - RE_Subprogram_Descriptors_Record, -- System.Exceptions - RE_Subprogram_Descriptors_Ptr, -- System.Exceptions - RE_Exn_Integer, -- System.Exn_Int RE_Exn_Long_Long_Float, -- System.Exn_LLF @@ -1421,6 +1418,10 @@ package Rtsfind is RE_Lt_F, -- System.Vax_Float_Operations RE_Lt_G, -- System.Vax_Float_Operations + RE_Valid_D, -- System.Vax_Float_Operations + RE_Valid_F, -- System.Vax_Float_Operations + RE_Valid_G, -- System.Vax_Float_Operations + RE_Version_String, -- System.Version_Control RE_Get_Version_String, -- System.Version_Control @@ -1599,21 +1600,33 @@ package Rtsfind is RE_DT_Prologue_Size => Ada_Tags, RE_External_Tag => Ada_Tags, RE_Get_Access_Level => Ada_Tags, + RE_Get_Entry_Index => Ada_Tags, RE_Get_External_Tag => Ada_Tags, RE_Get_Prim_Op_Address => Ada_Tags, + RE_Get_Prim_Op_Kind => Ada_Tags, RE_Get_RC_Offset => Ada_Tags, RE_Get_Remotely_Callable => Ada_Tags, RE_Inherit_DT => Ada_Tags, RE_Inherit_TSD => Ada_Tags, RE_Internal_Tag => Ada_Tags, RE_Is_Descendant_At_Same_Level => Ada_Tags, + RE_POK_Function => Ada_Tags, + RE_POK_Procedure => Ada_Tags, + RE_POK_Protected_Entry => Ada_Tags, + RE_POK_Protected_Function => Ada_Tags, + RE_POK_Protected_Procedure => Ada_Tags, + RE_POK_Task_Entry => Ada_Tags, + RE_POK_Task_Procedure => Ada_Tags, + RE_Prim_Op_Kind => Ada_Tags, RE_Register_Interface_Tag => Ada_Tags, RE_Register_Tag => Ada_Tags, RE_Set_Access_Level => Ada_Tags, + RE_Set_Entry_Index => Ada_Tags, RE_Set_Expanded_Name => Ada_Tags, RE_Set_External_Tag => Ada_Tags, RE_Set_Offset_To_Top => Ada_Tags, RE_Set_Prim_Op_Address => Ada_Tags, + RE_Set_Prim_Op_Kind => Ada_Tags, RE_Set_RC_Offset => Ada_Tags, RE_Set_Remotely_Callable => Ada_Tags, RE_Set_TSD => Ada_Tags, @@ -1744,20 +1757,6 @@ package Rtsfind is RE_Register_Exception => System_Exception_Table, - RE_All_Others_Id => System_Exceptions, - RE_Handler_Record => System_Exceptions, - RE_Handler_Record_Ptr => System_Exceptions, - RE_Others_Id => System_Exceptions, - RE_Subprogram_Descriptor => System_Exceptions, - RE_Subprogram_Descriptor_0 => System_Exceptions, - RE_Subprogram_Descriptor_1 => System_Exceptions, - RE_Subprogram_Descriptor_2 => System_Exceptions, - RE_Subprogram_Descriptor_3 => System_Exceptions, - RE_Subprogram_Descriptor_List => System_Exceptions, - RE_Subprogram_Descriptor_Ptr => System_Exceptions, - RE_Subprogram_Descriptors_Record => System_Exceptions, - RE_Subprogram_Descriptors_Ptr => System_Exceptions, - RE_Exn_Integer => System_Exn_Int, RE_Exn_Long_Long_Float => System_Exn_LLF, @@ -2525,6 +2524,10 @@ package Rtsfind is RE_Lt_F => System_Vax_Float_Operations, RE_Lt_G => System_Vax_Float_Operations, + RE_Valid_D => System_Vax_Float_Operations, + RE_Valid_F => System_Vax_Float_Operations, + RE_Valid_G => System_Vax_Float_Operations, + RE_Version_String => System_Version_Control, RE_Get_Version_String => System_Version_Control, @@ -2805,7 +2808,7 @@ package Rtsfind is -- not mean that an attempt to load it subsequently would fail. procedure Set_RTU_Loaded (N : Node_Id); - -- Register the predefined unit N as already loaded. + -- Register the predefined unit N as already loaded procedure Text_IO_Kludge (Nam : Node_Id); -- In Ada 83, and hence for compatibility in Ada 9X, package Text_IO has diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index d7e9ccc..190706c 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -1924,8 +1924,25 @@ package body Sem_Ch9 is and then Nkind (Trigger) /= N_Delay_Relative_Statement and then Nkind (Trigger) /= N_Entry_Call_Statement then - Error_Msg_N - ("triggering statement must be delay or entry call", Trigger); + if Ada_Version < Ada_05 then + Error_Msg_N + ("triggering statement must be delay or entry call", Trigger); + + -- Ada 2005 (AI-345): If a procedure_call_statement is used + -- for a procedure_or_entry_call, the procedure_name or pro- + -- cedure_prefix of the procedure_call_statement shall denote + -- an entry renamed by a procedure, or (a view of) a primitive + -- subprogram of a limited interface whose first parameter is + -- a controlling parameter. + + elsif Nkind (Trigger) = N_Procedure_Call_Statement + and then not Is_Renamed_Entry (Entity (Name (Trigger))) + and then not Is_Controlling_Limited_Procedure + (Entity (Name (Trigger))) + then + Error_Msg_N ("triggering statement must be delay, procedure " & + "or entry call", Trigger); + end if; end if; if Is_Non_Empty_List (Statements (N)) then @@ -2211,8 +2228,8 @@ package body Sem_Ch9 is and then Matches_Prefixed_View_Profile (Ifaces, Parameter_Specifications (Spec), Parameter_Specifications (Parent (Hom))) - and then Etype (Subtype_Mark (Spec)) = - Etype (Subtype_Mark (Parent (Hom))) + and then Etype (Result_Definition (Spec)) = + Etype (Result_Definition (Parent (Hom))) then Overrides := True; exit; diff --git a/gcc/ada/uintp.ads b/gcc/ada/uintp.ads index d7b3585..5a340b3 100644 --- a/gcc/ada/uintp.ads +++ b/gcc/ada/uintp.ads @@ -64,7 +64,10 @@ package Uintp is Uint_8 : constant Uint; Uint_9 : constant Uint; Uint_10 : constant Uint; + Uint_11 : constant Uint; Uint_12 : constant Uint; + Uint_13 : constant Uint; + Uint_14 : constant Uint; Uint_15 : constant Uint; Uint_16 : constant Uint; Uint_24 : constant Uint; @@ -430,7 +433,10 @@ private Uint_8 : constant Uint := Uint (Uint_Direct_Bias + 8); Uint_9 : constant Uint := Uint (Uint_Direct_Bias + 9); Uint_10 : constant Uint := Uint (Uint_Direct_Bias + 10); + Uint_11 : constant Uint := Uint (Uint_Direct_Bias + 11); Uint_12 : constant Uint := Uint (Uint_Direct_Bias + 12); + Uint_13 : constant Uint := Uint (Uint_Direct_Bias + 13); + Uint_14 : constant Uint := Uint (Uint_Direct_Bias + 14); Uint_15 : constant Uint := Uint (Uint_Direct_Bias + 15); Uint_16 : constant Uint := Uint (Uint_Direct_Bias + 16); Uint_24 : constant Uint := Uint (Uint_Direct_Bias + 24);