diff options
| -rw-r--r-- | gcc/ada/a-tags.adb | 133 | ||||
| -rw-r--r-- | gcc/ada/a-tags.ads | 88 | ||||
| -rw-r--r-- | gcc/ada/einfo.adb | 75 | ||||
| -rw-r--r-- | gcc/ada/einfo.ads | 51 | ||||
| -rw-r--r-- | gcc/ada/exp_ch3.adb | 148 | ||||
| -rw-r--r-- | gcc/ada/exp_ch7.adb | 15 | ||||
| -rw-r--r-- | gcc/ada/exp_ch9.adb | 2531 | ||||
| -rw-r--r-- | gcc/ada/exp_ch9.ads | 18 | ||||
| -rw-r--r-- | gcc/ada/exp_disp.adb | 1880 | ||||
| -rw-r--r-- | gcc/ada/exp_disp.ads | 126 | ||||
| -rw-r--r-- | gcc/ada/exp_util.adb | 96 | ||||
| -rw-r--r-- | gcc/ada/exp_util.ads | 6 | ||||
| -rw-r--r-- | gcc/ada/rtsfind.ads | 65 | ||||
| -rw-r--r-- | gcc/ada/sem_ch9.adb | 25 | ||||
| -rw-r--r-- | gcc/ada/uintp.ads | 6 |
15 files changed, 4416 insertions, 847 deletions
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 <temp>Nam is + -- begin + -- Stmts + -- end <temp>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 - <<index of first family member>> + - -- 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 <actual1-type> + -- ... + -- type AnnN is access all <actualN-type> + -- type Pnn is record + -- <formal1> : Ann1; + -- ... + -- <formalN> : 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 - <<index of first family member>> + + -- 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 <formal-type1>; + -- Jnn1 := <actual1>; + -- ... + -- P : Blk_Typ := ( + -- Jnn1'unchecked_access; + -- <actual2>'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: + -- <actual1> := P.<formal1>; + -- ... + -- <actualN> := P.<formalN>; + 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 <actual-type> + + 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 + -- <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 + -- <triggered-statements> -- end if; -- end; @@ -4250,20 +4647,17 @@ package body Exp_Ch9 is -- Mode => Asynchronous_Call; -- Block => Bnn); -- if Enqueued (Bnn) then - -- <abortable part> + -- <abortable-part> -- 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 + -- <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 (<dispatching-call>); + -- U : Boolean; + + -- procedure <temp>A is + -- begin + -- <abortable-statements> + -- end <temp>A; + + -- procedure <temp>T is + -- begin + -- <triggered-statements> + -- end <temp>T; + + -- begin + -- disp_get_prim_op_kind (<object>, S, C); + + -- if C = POK_Protected_Entry then + -- declare + -- procedure _clean is + -- begin + -- if Enqueued (Bnn) then + -- Cancel_Protected_Entry_Call (Bnn); + -- end if; + -- end _clean; + + -- begin + -- begin + -- disp_asynchronous_select + -- (Obj, S, P'address, Bnn, B); + + -- Param1 := P.Param1; + -- ... + -- ParamN := P.ParamN; + + -- if Enqueued (Bnn) then + -- <temp>A; + -- end if; + -- at end + -- _clean; + -- end; + -- exception + -- when Abort_Signal => Abort_Undefer; + -- end; + + -- if not Cancelled (Bnn) then + -- <temp>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 + -- (<object>, S, P'address, Bnn, B); + + -- Param1 := P.Param1; + -- ... + -- ParamN := P.ParamN; + + -- begin + -- begin + -- Abort_Undefer; + -- <temp>A; + -- at end + -- _clean; + -- end; + -- exception + -- when Abort_Signal => Abort_Undefer; + -- end; + + -- if not U then + -- <temp>T; + -- end if; + -- end; + + -- else + -- <dispatching-call>; + -- <temp>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. + Decls := New_List; + Stmts := New_List; - Dblock_Ent := Make_Defining_Identifier (Loc, New_Internal_Name ('D')); + -- Call status flag processing, generate: + -- B : Boolean := False; - Pdef := Entity (Name (Ecall)); + B := SEU.Build_B (Loc, Decls); - if Is_RTE (Pdef, RO_CA_Delay_For) then - Enqueue_Call := New_Reference_To (RTE (RE_Enqueue_Duration), Loc); + -- Communication block processing, generate: + -- Bnn : Communication_Block; - elsif Is_RTE (Pdef, RO_CA_Delay_Until) then - Enqueue_Call := New_Reference_To (RTE (RE_Enqueue_Calendar), Loc); + Bnn := Make_Defining_Identifier (Loc, New_Internal_Name ('B')); - else pragma Assert (Is_RTE (Pdef, RO_RT_Delay_Until)); - Enqueue_Call := New_Reference_To (RTE (RE_Enqueue_RT), Loc); - end if; + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + Bnn, + Object_Definition => + New_Reference_To (RTE (RE_Communication_Block), Loc))); - Append_To (Parameter_Associations (Ecall), - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Dblock_Ent, Loc), - Attribute_Name => Name_Unchecked_Access)); + -- Call kind processing, generate: + -- C : Ada.Tags.Prim_Op_Kind; - -- Create the inner block to protect the abortable part + C := SEU.Build_C (Loc, Decls); - 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))))); + -- Parameter block processing - Prepend_To (Astats, - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc))); + Blk_Typ := Build_Parameter_Block + (Loc, Actuals, Formals, Decls); + P := Parameter_Block_Pack + (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts); - 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); + -- Dispatch table slot processing, generate: + -- S : constant Integer := + -- DT_Position (<dispatching-procedure>); - -- Append call to if Enqueue (When, DB'Unchecked_Access) then + S := SEU.Build_S (Loc, Decls, Call_Ent); - 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))))); + -- Additional status flag processing, generate: - Stmts := New_List (Ecall); + U := Make_Defining_Identifier (Loc, Name_uU); - -- Construct statement sequence for new block + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + U, + Object_Definition => + New_Reference_To (Standard_Boolean, Loc))); - 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)); + -- Generate: + -- procedure <temp>A is + -- begin + -- Astmts + -- end <temp>A; - -- The result is the new block + Aproc := SEU.Build_Wrapping_Procedure (Loc, 'A', Decls, Astats); - Set_Entry_Cancel_Parameter (Blkent, Dblock_Ent); + -- Generate: + -- procedure <temp>T is + -- begin + -- Tstmts + -- end <temp>T; - 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))), + Tproc := SEU.Build_Wrapping_Procedure (Loc, 'T', Decls, Tstats); - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, Stmts))); + -- Generate: + -- _dispatching_get_prim_op_kind (<object>, S, C); - Analyze (N); - return; + 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 + -- (<object>, 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 + -- <temp>A + -- end if; + + -- where <temp>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 + -- <temp>T + -- end if; + + -- there <temp>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 + -- (<object>, 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; + -- <temp>A + + -- where <temp>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 + -- <temp>T + -- end if; + + -- where <temp>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: + -- <dispatching-call>; + -- <temp>T; + + -- where <temp>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 => <entry index>; @@ -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 - -- Append an if statement to execute the abortable part. - -- if Enqueued (Bnn) then + -- 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 (<dispatching-procedure>); + + -- begin + -- disp_conditional_select (<object>, S, P'address, C, B); + + -- if C = POK_Protected_Entry + -- or else C = POK_Task_Entry + -- then + -- Param1 := P.Param1; + -- ... + -- ParamN := P.ParamN; + -- end if; + + -- if B then + -- if C = POK_Procedure + -- or else C = POK_Protected_Procedure + -- or else C = POK_Task_Procedure + -- then + -- <dispatching-procedure> (<object>, Param1 .. ParamN); + -- end if; + -- <normal-statements> + -- else + -- <else-statements> + -- 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 (<dispatching-procedure>); + + S := SEU.Build_S (Loc, Decls, Call_Ent); + + -- Generate: + -- _dispatching_conditional_select (<object>, 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 + -- <dispatching-procedure-call> + -- end if; + -- <normal-statements> + -- else + -- <else-statements> + -- 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 -- <sequence of statements> -- 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 -- <sequence of statements> -- 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 <protected-function-name> (Param1 .. ParamN) return + -- <return-type> is + -- begin + -- return <protected-function-name>P (Param1 .. ParamN); + -- end <protected-function-name>; + -- + -- or + -- + -- procedure <protected-procedure-name> (Param1 .. ParamN) is + -- begin + -- <protected-procedure-name>P (Param1 .. ParamN); + -- end <protected-procedure-name> + + --------------------------------------- + -- Build_Dispatching_Subprogram_Body -- + --------------------------------------- + + function Build_Dispatching_Subprogram_Body + (N : Node_Id; + Pid : Node_Id; + Prot_Bod : Node_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (N); + Actuals : List_Id; + Formal : Node_Id; + Spec : Node_Id; + Stmts : List_Id; + + begin + -- Generate a specification without a letter suffix in order to + -- override an interface function or procedure. + + Spec := + Build_Protected_Sub_Specification (N, Pid, Dispatching_Mode); + + -- The formal parameters become the actuals of the protected + -- function or procedure call. + + Actuals := New_List; + Formal := First (Parameter_Specifications (Spec)); + + while Present (Formal) loop + Append_To (Actuals, + Make_Identifier (Loc, Chars (Defining_Identifier (Formal)))); + + Next (Formal); + end loop; + + if Nkind (Spec) = N_Procedure_Specification then + Stmts := + New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_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 := <entry index>; + -- B : Boolean; + -- X : Task_Entry_Index := <entry index>; -- DX : Duration := To_Duration (D); - -- M : Delay_Mode := <discriminant>; - -- P : parms := (parm, parm, parm); + -- M : Delay_Mode := <discriminant>; + -- P : parms := (parm, parm, parm); -- begin -- Timed_Protected_Entry_Call (<acceptor-task>, X, P'Address, @@ -8147,7 +9343,7 @@ package body Exp_Ch9 is -- B : Boolean; -- X : Protected_Entry_Index := <entry index>; -- DX : Duration := To_Duration (D); - -- M : Delay_Mode := <discriminant>; + -- M : Delay_Mode := <discriminant>; -- 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 (<dispatching-procedure>); + + -- begin + -- disp_timed_select (<object>, S, P'Address, DX, M, C, B); + + -- if C = POK_Protected_Entry + -- or else C = POK_Task_Entry + -- then + -- Param1 := P.Param1; + -- ... + -- ParamN := P.ParamN; + -- end if; + + -- if B then + -- if C = POK_Procedure + -- or else C = POK_Protected_Procedure + -- or else C = POK_Task_Procedure + -- then + -- 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; + + else + -- Build an entry call using Simple_Entry_Call - Extract_Entry (E_Call, Concval, Ename, Index); - Build_Simple_Entry_Call (E_Call, Concval, Ename, Index); + Extract_Entry (E_Call, Concval, Ename, Index); + Build_Simple_Entry_Call (E_Call, Concval, Ename, Index); - Stmts := Statements (Handled_Statement_Sequence (E_Call)); - Decls := Declarations (E_Call); + Decls := Declarations (E_Call); + Stmts := Statements (Handled_Statement_Sequence (E_Call)); - if No (Decls) then - Decls := New_List; + 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 (<dispatching-procedure>) - -- 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 + -- <dispatching-procedure-call> + -- end if; + -- <normal-statements> + -- else + -- <delay-statements> + -- 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 <formal-type> + + 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 := <actual> + + 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; + -- <actual2>'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: + -- <actual> := P.<formal>; + + 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 2707101b..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! (<type>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 <<type of the first formal>> @@ -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! (<type>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! (<type>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! (<type>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! (<type>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 (<tag>, <position>, <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 (<tag>, <position>, <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! (<type>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! (<type>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); |