diff options
| -rw-r--r-- | gcc/ada/a-tags.adb | 522 | ||||
| -rw-r--r-- | gcc/ada/a-tags.ads | 144 | ||||
| -rw-r--r-- | gcc/ada/exp_ch3.adb | 90 | ||||
| -rw-r--r-- | gcc/ada/exp_ch6.adb | 9 | ||||
| -rw-r--r-- | gcc/ada/exp_ch9.adb | 849 | ||||
| -rw-r--r-- | gcc/ada/exp_disp.adb | 682 | ||||
| -rw-r--r-- | gcc/ada/exp_disp.ads | 13 | ||||
| -rw-r--r-- | gcc/ada/exp_sel.adb | 220 | ||||
| -rw-r--r-- | gcc/ada/exp_sel.ads | 113 | ||||
| -rw-r--r-- | gcc/ada/rtsfind.ads | 55 |
10 files changed, 1750 insertions, 947 deletions
diff --git a/gcc/ada/a-tags.adb b/gcc/ada/a-tags.adb index 8c9312e205c..a8d6cd00109 100644 --- a/gcc/ada/a-tags.adb +++ b/gcc/ada/a-tags.adb @@ -41,47 +41,53 @@ package body Ada.Tags is -- Structure of the GNAT Primary Dispatch Table --- +-----------------------+ --- | Signature | --- +-----------------------+ --- | Offset_To_Top | --- +-----------------------+ --- | Typeinfo_Ptr/TSD_Ptr | ---> Type Specific Data --- Tag ---> +-----------------------+ +-------------------+ --- | table of | | inheritance depth | --- : primitive ops : +-------------------+ --- | pointers | | access level | --- +-----------------------+ +-------------------+ --- | expanded name | --- +-------------------+ --- | external tag | --- +-------------------+ --- | hash table link | --- +-------------------+ --- | remotely callable | --- +-------------------+ --- | rec ctrler offset | --- +-------------------+ --- | num prim ops | --- +-------------------+ --- | num interfaces | --- +-------------------+ --- Select Specific Data <--- | SSD_Ptr | --- +-----------------------+ +-------------------+ --- | table of primitive | | table of | --- : operation : : ancestor : --- | kinds | | tags | --- +-----------------------+ +-------------------+ --- | table of | | table of | --- : entry : : interface : --- | indices | | tags | --- +-----------------------+ +-------------------+ +-- +----------------------+ +-- | Signature | +-- +----------------------+ +-- | Tagged_Kind | +-- +----------------------+ +-- | Offset_To_Top | +-- +----------------------+ +-- | Typeinfo_Ptr/TSD_Ptr ---> Type Specific Data +-- Tag ---> +----------------------+ +-------------------+ +-- | table of | | inheritance depth | +-- : primitive ops : +-------------------+ +-- | pointers | | access level | +-- +----------------------+ +-------------------+ +-- | expanded name | +-- +-------------------+ +-- | external tag | +-- +-------------------+ +-- | hash table link | +-- +-------------------+ +-- | remotely callable | +-- +-------------------+ +-- | rec ctrler offset | +-- +-------------------+ +-- | num prim ops | +-- +-------------------+ +-- | num interfaces | +-- +-------------------+ +-- | Ifaces_Table_Ptr --> Interface Data +-- +-------------------+ +------------+ +-- Select Specific Data <---- SSD_Ptr | | table | +-- +--------------------+ +-------------------+ : of : +-- | table of primitive | | table of | | interfaces | +-- : operation : : ancestor : +------------+ +-- | kinds | | tags | +-- +--------------------+ +-------------------+ +-- | table of | +-- : entry : +-- | indices | +-- +--------------------+ -- Structure of the GNAT Secondary Dispatch Table -- +-----------------------+ -- | Signature | -- +-----------------------+ +-- | Tagged_Kind | +-- +-----------------------+ -- | Offset_To_Top | -- +-----------------------+ -- | OSD_Ptr |---> Object Specific Data @@ -93,10 +99,77 @@ package body Ada.Tags is -- | op offsets | -- +---------------+ - Offset_To_Signature : constant SSE.Storage_Count := - DT_Typeinfo_Ptr_Size - + DT_Offset_To_Top_Size - + DT_Signature_Size; + ---------------------------------- + -- GNAT Dispatch Table Prologue -- + ---------------------------------- + + -- GNAT's Dispatch Table prologue contains several fields which are hidden + -- in order to preserve compatibility with C++. These fields are accessed + -- by address calculations performed in the following manner: + + -- Field : Field_Type := + -- (To_Address (Tag) - Sum_Of_Preceding_Field_Sizes).all; + + -- The bracketed subtraction shifts the pointer (Tag) from the table of + -- primitive operations (or thunks) to the field in question. Since the + -- result of the subtraction is an address, dereferencing it will obtain + -- the actual value of the field. + + -- Guidelines for addition of new hidden fields + + -- Define a Field_Type and Field_Type_Ptr (access to Field_Type) in + -- A-Tags.ads for the newly introduced field. + + -- Defined the size of the new field as a constant Field_Name_Size + + -- Introduce an Unchecked_Conversion from System.Address to + -- Field_Type_Ptr in A-Tags.ads. + + -- Define the specifications of Get_<Field_Name> and Set_<Field_Name> + -- in A-Tags.ads. + + -- Update the GNAT Dispatch Table structure in A-Tags.adb + + -- Provide bodies to the Get_<Field_Name> and Set_<Field_Name> routines. + -- The profile of a Get_<Field_Name> routine should resemble: + + -- function Get_<Field_Name> (T : Tag; ...) return Field_Type is + -- Field : constant System.Address := + -- To_Address (T) - <Sum_Of_Previous_Field_Sizes>; + -- begin + -- pragma Assert (Check_Signature (T, <Applicable_DT>)); + -- <Additional_Assertions> + + -- return To_Field_Type_Ptr (Field).all; + -- end Get_<Field_Name>; + + -- The profile of a Set_<Field_Name> routine should resemble: + + -- procedure Set_<Field_Name> (T : Tag; ..., Value : Field_Type) is + -- Field : constant System.Address := + -- To_Address (T) - <Sum_Of_Previous_Field_Sizes>; + -- begin + -- pragma Assert (Check_Signature (T, <Applicable_DT>)); + -- <Additional_Assertions> + + -- To_Field_Type_Ptr (Field).all := Value; + -- end Set_<Field_Name>; + + -- NOTE: For each field in the prologue which precedes the newly added + -- one, find and update its respective Sum_Of_Previous_Field_Sizes by + -- subtractind Field_Name_Size from it. Falure to do so will clobber the + -- previous prologue field. + + K_Typeinfo : constant SSE.Storage_Count := DT_Typeinfo_Ptr_Size; + + K_Offset_To_Top : constant SSE.Storage_Count := + K_Typeinfo + DT_Offset_To_Top_Size; + + K_Tagged_Kind : constant SSE.Storage_Count := + K_Offset_To_Top + DT_Tagged_Kind_Size; + + K_Signature : constant SSE.Storage_Count := + K_Tagged_Kind + DT_Signature_Size; subtype Cstring is String (Positive); type Cstring_Ptr is access all Cstring; @@ -108,6 +181,20 @@ package body Ada.Tags is pragma Suppress_Initialization (Tag_Table); pragma Suppress (Index_Check, On => Tag_Table); + -- Declarations for the table of interfaces + + type Interface_Data_Element is record + Iface_Tag : Tag; + Offset : System.Storage_Elements.Storage_Offset; + end record; + + type Interfaces_Array is + array (Natural range <>) of Interface_Data_Element; + + type Interface_Data (Nb_Ifaces : Positive) is record + Table : Interfaces_Array (1 .. Nb_Ifaces); + end record; + -- Object specific data types type Object_Specific_Data_Array is array (Positive range <>) of Positive; @@ -171,17 +258,16 @@ package body Ada.Tags is -- Controller Offset: Used to give support to tagged controlled objects -- (see Get_Deep_Controller at s-finimp) + Ifaces_Table_Ptr : System.Address; + -- Pointer to the table of interface tags. It is used to implement the + -- membership test associated with interfaces and also for backward + -- abstract interface type conversions (Ada 2005:AI-251) + Num_Prim_Ops : Natural; -- Number of primitive operations of the dispatch table. This field is -- used for additional run-time checks when the run-time is compiled -- with assertions enabled. - 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 - -- membership test associated with interfaces (Ada 2005:AI-251). - SSD_Ptr : System.Address; -- Pointer to a table of records used in dispatching selects. This -- field has a meaningful value for all tagged types that implement @@ -210,6 +296,8 @@ package body Ada.Tags is -- enough space for these additional components, and generates code that -- displaces the _Tag to point after these components. + -- Signature : Signature_Kind; + -- Tagged_Kind : Tagged_Kind; -- Offset_To_Top : Natural; -- Typeinfo_Ptr : System.Address; @@ -305,11 +393,6 @@ package body Ada.Tags is -- Length of string represented by the given pointer (treating the string -- as a C-style string, which is Nul terminated). - function Offset_To_Top - (T : Tag) return System.Storage_Elements.Storage_Offset; - -- Returns the current value of the offset_to_top component available in - -- the prologue of the dispatch table. - function Typeinfo_Ptr (T : Tag) return System.Address; -- Returns the current value of the typeinfo_ptr component available in -- the prologue of the dispatch table. @@ -425,21 +508,20 @@ package body Ada.Tags is --------------------- function Check_Signature (T : Tag; Kind : Signature_Type) return Boolean is - Offset_To_Top_Ptr : constant Storage_Offset_Ptr := - To_Storage_Offset_Ptr (To_Address (T) - - Offset_To_Signature); + Signature : constant Storage_Offset_Ptr := + To_Storage_Offset_Ptr (To_Address (T) - K_Signature); - Signature : constant Signature_Values := - To_Signature_Values (Offset_To_Top_Ptr.all); + Sig_Values : constant Signature_Values := + To_Signature_Values (Signature.all); Signature_Id : Signature_Kind; begin - if Signature (1) /= Valid_Signature then + if Sig_Values (1) /= Valid_Signature then Signature_Id := Unknown; - elsif Signature (2) in Primary_DT .. Abstract_Interface then - Signature_Id := Signature (2); + elsif Sig_Values (2) in Primary_DT .. Abstract_Interface then + Signature_Id := Sig_Values (2); else Signature_Id := Unknown; @@ -522,6 +604,54 @@ package body Ada.Tags is return Pos >= 0 and then TSD (Obj_Tag).Tags_Table (Pos) = Typ_Tag; end CW_Membership; + -------------- + -- Displace -- + -------------- + + function Displace + (This : System.Address; + T : Tag) return System.Address + is + Curr_DT : constant Tag := To_Tag_Ptr (This).all; + Iface_Table : Interface_Data_Ptr; + Obj_Base : System.Address; + Obj_DT : Tag; + Obj_TSD : Type_Specific_Data_Ptr; + + begin + pragma Assert + (Check_Signature (Curr_DT, Must_Be_Primary_Or_Secondary_DT)); + pragma Assert + (Check_Signature (T, Must_Be_Interface)); + + Obj_Base := This - Offset_To_Top (Curr_DT); + Obj_DT := To_Tag_Ptr (Obj_Base).all; + + pragma Assert + (Check_Signature (Obj_DT, Must_Be_Primary_DT)); + + Obj_TSD := TSD (Obj_DT); + Iface_Table := To_Interface_Data_Ptr (Obj_TSD.Ifaces_Table_Ptr); + + if Iface_Table /= null then + for Id in 1 .. Iface_Table.Nb_Ifaces loop + if Iface_Table.Table (Id).Iface_Tag = T then + Obj_Base := Obj_Base + Iface_Table.Table (Id).Offset; + Obj_DT := To_Tag_Ptr (Obj_Base).all; + + pragma Assert + (Check_Signature (Obj_DT, Must_Be_Secondary_DT)); + + return Obj_Base; + end if; + end loop; + end if; + + -- If the object does not implement the interface we must raise CE + + raise Constraint_Error; + end Displace; + ------------------- -- IW_Membership -- ------------------- @@ -537,12 +667,12 @@ package body Ada.Tags is -- that are contained in the dispatch table referenced by Obj'Tag. function IW_Membership (This : System.Address; T : Tag) return Boolean is - Curr_DT : constant Tag := To_Tag_Ptr (This).all; - Id : Natural; - Last_Id : Natural; - Obj_Base : System.Address; - Obj_DT : Tag; - Obj_TSD : Type_Specific_Data_Ptr; + Curr_DT : constant Tag := To_Tag_Ptr (This).all; + Iface_Table : Interface_Data_Ptr; + Last_Id : Natural; + Obj_Base : System.Address; + Obj_DT : Tag; + Obj_TSD : Type_Specific_Data_Ptr; begin pragma Assert @@ -554,29 +684,32 @@ package body Ada.Tags is Obj_DT := To_Tag_Ptr (Obj_Base).all; pragma Assert - (Check_Signature (Curr_DT, Must_Be_Primary_DT)); + (Check_Signature (Obj_DT, Must_Be_Primary_DT)); Obj_TSD := TSD (Obj_DT); - Last_Id := Obj_TSD.Idepth + Obj_TSD.Num_Interfaces; - - if Obj_TSD.Num_Interfaces > 0 then + Last_Id := Obj_TSD.Idepth; - -- Traverse the ancestor tags table plus the interface tags table. - -- The former part is required for: + -- Look for the tag in the table of interfaces - -- Iface_CW in Typ'Class + Iface_Table := To_Interface_Data_Ptr (Obj_TSD.Ifaces_Table_Ptr); - Id := 0; - loop - if Obj_TSD.Tags_Table (Id) = T then + if Iface_Table /= null then + for Id in 1 .. Iface_Table.Nb_Ifaces loop + if Iface_Table.Table (Id).Iface_Tag = T then return True; end if; - - Id := Id + 1; - exit when Id > Last_Id; end loop; end if; + -- Look for the tag in the ancestor tags table. This is required for: + -- Iface_CW in Typ'Class + + for Id in 0 .. Last_Id loop + if Obj_TSD.Tags_Table (Id) = T then + return True; + end if; + end loop; + return False; end IW_Membership; @@ -652,6 +785,7 @@ package body Ada.Tags is Index : constant Integer := Position - Default_Prim_Op_Count; begin pragma Assert (Check_Signature (T, Must_Be_Primary_DT)); + pragma Assert (Check_Index (T, Position)); pragma Assert (Index > 0); return SSD (T).SSD_Table (Index).Index; end Get_Entry_Index; @@ -677,7 +811,7 @@ package body Ada.Tags is if Is_Primary_DT (T) then return TSD (T).Num_Prim_Ops; else - return OSD (Interface_Tag (T)).Num_Prim_Ops; + return OSD (T).Num_Prim_Ops; end if; end Get_Num_Prim_Ops; @@ -706,6 +840,7 @@ package body Ada.Tags is Index : constant Integer := Position - Default_Prim_Op_Count; begin pragma Assert (Check_Signature (T, Must_Be_Primary_DT)); + pragma Assert (Check_Index (T, Position)); pragma Assert (Index > 0); return SSD (T).SSD_Table (Index).Kind; end Get_Prim_Op_Kind; @@ -715,12 +850,13 @@ package body Ada.Tags is ---------------------- function Get_Offset_Index - (T : Interface_Tag; + (T : Tag; Position : Positive) return Positive is Index : constant Integer := Position - Default_Prim_Op_Count; begin - pragma Assert (Check_Signature (Tag (T), Must_Be_Secondary_DT)); + pragma Assert (Check_Signature (T, Must_Be_Secondary_DT)); + pragma Assert (Check_Index (T, Position)); pragma Assert (Index > 0); return OSD (T).OSD_Table (Index); end Get_Offset_Index; @@ -745,6 +881,18 @@ package body Ada.Tags is return TSD (T).Remotely_Callable; end Get_Remotely_Callable; + --------------------- + -- Get_Tagged_Kind -- + --------------------- + + function Get_Tagged_Kind (T : Tag) return Tagged_Kind is + Tagged_Kind_Ptr : constant System.Address := + To_Address (T) - K_Tagged_Kind; + begin + pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT)); + return To_Tagged_Kind_Ptr (Tagged_Kind_Ptr).all; + end Get_Tagged_Kind; + ---------------- -- Inherit_DT -- ---------------- @@ -766,8 +914,10 @@ package body Ada.Tags is ----------------- procedure Inherit_TSD (Old_Tag : Tag; New_Tag : Tag) is - New_TSD_Ptr : Type_Specific_Data_Ptr; - Old_TSD_Ptr : Type_Specific_Data_Ptr; + New_TSD_Ptr : Type_Specific_Data_Ptr; + New_Iface_Table_Ptr : Interface_Data_Ptr; + Old_TSD_Ptr : Type_Specific_Data_Ptr; + Old_Iface_Table_Ptr : Interface_Data_Ptr; begin pragma Assert (Check_Signature (New_Tag, Must_Be_Primary_Or_Interface)); @@ -778,18 +928,29 @@ package body Ada.Tags is (Check_Signature (Old_Tag, Must_Be_Primary_Or_Interface)); Old_TSD_Ptr := TSD (Old_Tag); New_TSD_Ptr.Idepth := Old_TSD_Ptr.Idepth + 1; - New_TSD_Ptr.Num_Interfaces := Old_TSD_Ptr.Num_Interfaces; -- Copy the "table of ancestor tags" plus the "table of interfaces" -- 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); + New_TSD_Ptr.Tags_Table (1 .. New_TSD_Ptr.Idepth) := + Old_TSD_Ptr.Tags_Table (0 .. Old_TSD_Ptr.Idepth); + + -- Copy the table of interfaces of the parent + + if not System."=" (Old_TSD_Ptr.Ifaces_Table_Ptr, + System.Null_Address) + then + Old_Iface_Table_Ptr := + To_Interface_Data_Ptr (Old_TSD_Ptr.Ifaces_Table_Ptr); + New_Iface_Table_Ptr := + To_Interface_Data_Ptr (New_TSD_Ptr.Ifaces_Table_Ptr); + + New_Iface_Table_Ptr.Table (1 .. Old_Iface_Table_Ptr.Nb_Ifaces) := + Old_Iface_Table_Ptr.Table (1 .. Old_Iface_Table_Ptr.Nb_Ifaces); + end if; + else - New_TSD_Ptr.Idepth := 0; - New_TSD_Ptr.Num_Interfaces := 0; + New_TSD_Ptr.Idepth := 0; end if; New_TSD_Ptr.Tags_Table (0) := New_Tag; @@ -845,13 +1006,12 @@ package body Ada.Tags is ------------------- function Is_Primary_DT (T : Tag) return Boolean is - Offset_To_Top_Ptr : constant Storage_Offset_Ptr := - To_Storage_Offset_Ptr (To_Address (T) - - Offset_To_Signature); - Signature : constant Signature_Values := - To_Signature_Values (Offset_To_Top_Ptr.all); + Signature : constant Storage_Offset_Ptr := + To_Storage_Offset_Ptr (To_Address (T) - K_Signature); + Sig_Values : constant Signature_Values := + To_Signature_Values (Signature.all); begin - return Signature (2) = Primary_DT; + return Sig_Values (2) = Primary_DT; end Is_Primary_DT; ------------ @@ -876,26 +1036,22 @@ package body Ada.Tags is function Offset_To_Top (T : Tag) return System.Storage_Elements.Storage_Offset is - Offset_To_Top_Ptr : constant Storage_Offset_Ptr := - To_Storage_Offset_Ptr (To_Address (T) - - DT_Typeinfo_Ptr_Size - - DT_Offset_To_Top_Size); - + Offset_To_Top : constant Storage_Offset_Ptr := + To_Storage_Offset_Ptr + (To_Address (T) - K_Offset_To_Top); begin - return Offset_To_Top_Ptr.all; + return Offset_To_Top.all; end Offset_To_Top; --------- -- OSD -- --------- - function OSD - (T : Interface_Tag) return Object_Specific_Data_Ptr - is - OSD_Ptr : Addr_Ptr; - + function OSD (T : Tag) return Object_Specific_Data_Ptr is + OSD_Ptr : constant Addr_Ptr := + To_Addr_Ptr (To_Address (T) - K_Typeinfo); begin - OSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + pragma Assert (Check_Signature (T, Must_Be_Secondary_DT)); return To_Object_Specific_Data_Ptr (OSD_Ptr.all); end OSD; @@ -952,39 +1108,24 @@ package body Ada.Tags is -- Register_Interface_Tag -- ---------------------------- - procedure Register_Interface_Tag (T : Tag; Interface_T : Tag) is - New_T_TSD : Type_Specific_Data_Ptr; - Index : Natural; + procedure Register_Interface_Tag + (T : Tag; + Interface_T : Tag; + Position : Positive) + is + New_T_TSD : Type_Specific_Data_Ptr; + Iface_Table : Interface_Data_Ptr; begin pragma Assert (Check_Signature (T, Must_Be_Primary_DT)); pragma Assert (Check_Signature (Interface_T, Must_Be_Interface)); - New_T_TSD := TSD (T); - - -- Check if the interface is already registered - - if New_T_TSD.Num_Interfaces > 0 then - declare - Id : Natural := New_T_TSD.Idepth + 1; - Last_Id : constant Natural := New_T_TSD.Idepth - + New_T_TSD.Num_Interfaces; + New_T_TSD := TSD (T); + Iface_Table := To_Interface_Data_Ptr (New_T_TSD.Ifaces_Table_Ptr); - begin - loop - if New_T_TSD.Tags_Table (Id) = Interface_T then - return; - end if; - - Id := Id + 1; - exit when Id > Last_Id; - end loop; - end; - end if; + pragma Assert (Position <= Iface_Table.Nb_Ifaces); - New_T_TSD.Num_Interfaces := New_T_TSD.Num_Interfaces + 1; - Index := New_T_TSD.Idepth + New_T_TSD.Num_Interfaces; - New_T_TSD.Tags_Table (Index) := Interface_T; + Iface_Table.Table (Position).Iface_Tag := Interface_T; end Register_Interface_Tag; ------------------ @@ -1016,9 +1157,9 @@ package body Ada.Tags is Value : Positive) is Index : constant Integer := Position - Default_Prim_Op_Count; - begin pragma Assert (Check_Signature (T, Must_Be_Primary_DT)); + pragma Assert (Check_Index (T, Position)); pragma Assert (Index > 0); SSD (T).SSD_Table (Index).Index := Value; end Set_Entry_Index; @@ -1044,6 +1185,16 @@ package body Ada.Tags is TSD (T).External_Tag := To_Cstring_Ptr (Value); end Set_External_Tag; + ------------------------- + -- Set_Interface_Table -- + ------------------------- + + procedure Set_Interface_Table (T : Tag; Value : System.Address) is + begin + pragma Assert (Check_Signature (T, Must_Be_Primary_DT)); + TSD (T).Ifaces_Table_Ptr := Value; + end Set_Interface_Table; + ---------------------- -- Set_Num_Prim_Ops -- ---------------------- @@ -1055,7 +1206,7 @@ package body Ada.Tags is if Is_Primary_DT (T) then TSD (T).Num_Prim_Ops := Value; else - OSD (Interface_Tag (T)).Num_Prim_Ops := Value; + OSD (T).Num_Prim_Ops := Value; end if; end Set_Num_Prim_Ops; @@ -1064,13 +1215,14 @@ package body Ada.Tags is ---------------------- procedure Set_Offset_Index - (T : Interface_Tag; + (T : Tag; Position : Positive; Value : Positive) is Index : constant Integer := Position - Default_Prim_Op_Count; begin - pragma Assert (Check_Signature (Tag (T), Must_Be_Secondary_DT)); + pragma Assert (Check_Signature (T, Must_Be_Secondary_DT)); + pragma Assert (Check_Index (T, Position)); pragma Assert (Index > 0); OSD (T).OSD_Table (Index) := Value; end Set_Offset_Index; @@ -1080,27 +1232,78 @@ package body Ada.Tags is ----------------------- procedure Set_Offset_To_Top - (T : Tag; - Value : System.Storage_Elements.Storage_Offset) + (This : System.Address; + Interface_T : Tag; + Offset_Value : System.Storage_Elements.Storage_Offset) is - Offset_To_Top_Ptr : constant Storage_Offset_Ptr := - To_Storage_Offset_Ptr (To_Address (T) - - DT_Typeinfo_Ptr_Size - - DT_Offset_To_Top_Size); + Prim_DT : Tag; + Sec_Base : System.Address; + Sec_DT : Tag; + Offset_To_Top : Storage_Offset_Ptr; + Iface_Table : Interface_Data_Ptr; + Obj_TSD : Type_Specific_Data_Ptr; begin - pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT)); - Offset_To_Top_Ptr.all := Value; + if System."=" (This, System.Null_Address) then + pragma Assert + (Check_Signature (Interface_T, Must_Be_Primary_DT)); + pragma Assert (Offset_Value = 0); + + Offset_To_Top := + To_Storage_Offset_Ptr (To_Address (Interface_T) - K_Offset_To_Top); + Offset_To_Top.all := Offset_Value; + return; + end if; + + -- "This" points to the primary DT and we must save Offset_Value in the + -- Offset_To_Top field of the corresponding secondary dispatch table. + + Prim_DT := To_Tag_Ptr (This).all; + + pragma Assert + (Check_Signature (Prim_DT, Must_Be_Primary_DT)); + + Sec_Base := This + Offset_Value; + Sec_DT := To_Tag_Ptr (Sec_Base).all; + Offset_To_Top := + To_Storage_Offset_Ptr (To_Address (Sec_DT) - K_Offset_To_Top); + + pragma Assert + (Check_Signature (Sec_DT, Must_Be_Primary_Or_Secondary_DT)); + + Offset_To_Top.all := Offset_Value; + + -- Save Offset_Value in the table of interfaces of the primary DT. This + -- data will be used by the subprogram "Displace" to give support to + -- backward abstract interface type conversions. + + Obj_TSD := TSD (Prim_DT); + Iface_Table := To_Interface_Data_Ptr (Obj_TSD.Ifaces_Table_Ptr); + + -- Register the offset in the table of interfaces + + if Iface_Table /= null then + for Id in 1 .. Iface_Table.Nb_Ifaces loop + if Iface_Table.Table (Id).Iface_Tag = Interface_T then + Iface_Table.Table (Id).Offset := Offset_Value; + return; + end if; + end loop; + end if; + + -- If we arrive here there is some error in the run-time data structure + + raise Program_Error; end Set_Offset_To_Top; ------------- -- Set_OSD -- ------------- - procedure Set_OSD (T : Interface_Tag; Value : System.Address) is - OSD_Ptr : Addr_Ptr; + procedure Set_OSD (T : Tag; Value : System.Address) is + OSD_Ptr : constant Addr_Ptr := + To_Addr_Ptr (To_Address (T) - K_Typeinfo); begin - pragma Assert (Check_Signature (Tag (T), Must_Be_Secondary_DT)); - OSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + pragma Assert (Check_Signature (T, Must_Be_Secondary_DT)); OSD_Ptr.all := Value; end Set_OSD; @@ -1131,6 +1334,7 @@ package body Ada.Tags is Index : constant Integer := Position - Default_Prim_Op_Count; begin pragma Assert (Check_Signature (T, Must_Be_Primary_DT)); + pragma Assert (Check_Index (T, Position)); pragma Assert (Index > 0); SSD (T).SSD_Table (Index).Kind := Value; end Set_Prim_Op_Kind; @@ -1165,6 +1369,18 @@ package body Ada.Tags is TSD (T).SSD_Ptr := Value; end Set_SSD; + --------------------- + -- Set_Tagged_Kind -- + --------------------- + + procedure Set_Tagged_Kind (T : Tag; Value : Tagged_Kind) is + Tagged_Kind_Ptr : constant System.Address := + To_Address (T) - K_Tagged_Kind; + begin + pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT)); + To_Tagged_Kind_Ptr (Tagged_Kind_Ptr).all := Value; + end Set_Tagged_Kind; + ------------- -- Set_TSD -- ------------- @@ -1173,7 +1389,7 @@ package body Ada.Tags is TSD_Ptr : Addr_Ptr; begin pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface)); - TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + TSD_Ptr := To_Addr_Ptr (To_Address (T) - K_Typeinfo); TSD_Ptr.all := Value; end Set_TSD; @@ -1183,6 +1399,7 @@ package body Ada.Tags is function SSD (T : Tag) return Select_Specific_Data_Ptr is begin + pragma Assert (Check_Signature (T, Must_Be_Primary_DT)); return To_Select_Specific_Data_Ptr (TSD (T).SSD_Ptr); end SSD; @@ -1192,7 +1409,7 @@ package body Ada.Tags is function Typeinfo_Ptr (T : Tag) return System.Address is TSD_Ptr : constant Addr_Ptr := - To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + To_Addr_Ptr (To_Address (T) - K_Typeinfo); begin return TSD_Ptr.all; end Typeinfo_Ptr; @@ -1203,8 +1420,9 @@ package body Ada.Tags is function TSD (T : Tag) return Type_Specific_Data_Ptr is TSD_Ptr : constant Addr_Ptr := - To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + To_Addr_Ptr (To_Address (T) - K_Typeinfo); begin + pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface)); return To_Type_Specific_Data_Ptr (TSD_Ptr.all); end TSD; diff --git a/gcc/ada/a-tags.ads b/gcc/ada/a-tags.ads index 46e6c204167..25fed4f1dcb 100644 --- a/gcc/ada/a-tags.ads +++ b/gcc/ada/a-tags.ads @@ -102,6 +102,11 @@ private No_Tag : constant Tag := null; + type Interface_Data (Nb_Ifaces : Positive); + type Interface_Data_Ptr is access all Interface_Data; + -- Table of abstract interfaces used to give support to backward interface + -- conversions and also to IW_Membership. + type Object_Specific_Data (Nb_Prim : Positive); type Object_Specific_Data_Ptr is access all Object_Specific_Data; -- Information associated with the secondary dispatch table of tagged-type @@ -132,6 +137,18 @@ private POK_Task_Function, POK_Task_Procedure); + -- Tagged type kinds with respect to concurrency and limitedness + + type Tagged_Kind is + (TK_Abstract_Limited_Tagged, + TK_Abstract_Tagged, + TK_Limited_Tagged, + TK_Protected, + TK_Tagged, + TK_Task); + + type Tagged_Kind_Ptr is access all Tagged_Kind; + Default_Prim_Op_Count : constant Positive := 15; -- Number of predefined primitive operations added by the Expander for a -- tagged type. It is utilized for indexing in the two auxiliary tables @@ -160,6 +177,10 @@ private -- return O in T'Class. -- end Test; + function Displace (This : System.Address; T : Tag) return System.Address; + -- (Ada 2005 (AI-251): Displace "This" to point to the secondary dispatch + -- table of T. + function Get_Access_Level (T : Tag) return Natural; -- Given the tag associated with a type, returns the accessibility level -- of the type. @@ -173,7 +194,7 @@ private -- the external name. function Get_Offset_Index - (T : Interface_Tag; + (T : Tag; Position : Positive) return Positive; -- Given a pointer to a secondary dispatch table (T) and a position of an -- operation in the DT, retrieve the corresponding operation's position in @@ -204,6 +225,11 @@ private function Get_Remotely_Callable (T : Tag) return Boolean; -- Return the value previously set by Set_Remotely_Callable + function Get_Tagged_Kind (T : Tag) return Tagged_Kind; + -- Given a pointer to either a primary or a secondary dispatch table, + -- return the tagged kind of a type in the context of concurrency and + -- limitedness. + procedure Inherit_DT (Old_T : Tag; New_T : Tag; Entry_Count : Natural); -- Entry point used to initialize the DT of a type knowing the tag -- of the direct ancestor and the number of primitive ops that are @@ -212,7 +238,12 @@ private procedure Inherit_TSD (Old_Tag : Tag; New_Tag : Tag); -- Initialize the TSD of a type knowing the tag of the direct ancestor - function OSD (T : Interface_Tag) return Object_Specific_Data_Ptr; + function Offset_To_Top + (T : Tag) return System.Storage_Elements.Storage_Offset; + -- Returns the current value of the offset_to_top component available in + -- the prologue of the dispatch table. + + function OSD (T : Tag) return Object_Specific_Data_Ptr; -- Ada 2005 (AI-251): Given a pointer T to a secondary dispatch table, -- retrieve the address of the record containing the Objet Specific -- Data table. @@ -228,38 +259,63 @@ private pragma Export (Ada, Parent_Size, "ada__tags__parent_size"); -- This procedure is used in s-finimp and is thus exported manually - procedure Register_Interface_Tag (T : Tag; Interface_T : Tag); + procedure Register_Interface_Tag + (T : Tag; + Interface_T : Tag; + Position : Positive); -- Ada 2005 (AI-251): Used to initialize the table of interfaces - -- implemented by a type. Required to give support to IW_Membership. + -- implemented by a type. Required to give support to backward interface + -- conversions and also to IW_Membership. procedure Register_Tag (T : Tag); -- Insert the Tag and its associated external_tag in a table for the -- sake of Internal_Tag + procedure Set_Access_Level (T : Tag; Value : Natural); + -- Sets the accessibility level of the tagged type associated with T + -- in its TSD. + 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_Expanded_Name (T : Tag; Value : System.Address); + -- Set the address of the string containing the expanded name + -- 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. + + procedure Set_Interface_Table (T : Tag; Value : System.Address); + -- Ada 2005 (AI-251): Given a pointer T to a dispatch Table, stores the + -- pointer to the table of interfaces. + procedure Set_Num_Prim_Ops (T : Tag; Value : Natural); -- Set the number of primitive operations in the dispatch table of T. This -- is used for debugging purposes. procedure Set_Offset_Index - (T : Interface_Tag; + (T : Tag; Position : Positive; Value : Positive); -- Set the offset value of a primitive operation in a secondary dispatch -- table denoted by T, indexed by Position. procedure Set_Offset_To_Top - (T : Tag; - Value : System.Storage_Elements.Storage_Offset); + (This : System.Address; + Interface_T : Tag; + Offset_Value : System.Storage_Elements.Storage_Offset); -- Ada 2005 (AI-251): Initialize the Offset_To_Top field in the prologue of - -- the dispatch table. In primary dispatch tables the value of this field - -- is always 0; in secondary dispatch tables this is the offset to the base - -- of the enclosing type. - - procedure Set_OSD (T : Interface_Tag; Value : System.Address); + -- the dispatch table. In primary dispatch tables the value of "This" is + -- not required (and the compiler passes always the Null_Address value) and + -- the Offset_Value is always cero; in secondary dispatch tables "This" + -- points to the object, Interface_T is the interface for which the + -- secondary dispatch table is being initialized, and Offset_Value is the + -- distance from "This" to the object component containing the tag of the + -- secondary dispatch table. + + procedure Set_OSD (T : Tag; Value : System.Address); -- Given a pointer T to a secondary dispatch table, store the pointer to -- the record containing the Object Specific Data generated by GNAT. @@ -278,26 +334,6 @@ private -- Set the kind of a primitive operation in T's TSD table indexed by -- Position. - procedure Set_SSD (T : Tag; Value : System.Address); - -- Given a pointer T to a dispatch Table, stores the pointer to the record - -- containing the Select Specific Data generated by GNAT. - - 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. - - procedure Set_Access_Level (T : Tag; Value : Natural); - -- Sets the accessibility level of the tagged type associated with T - -- in its TSD. - - procedure Set_Expanded_Name (T : Tag; Value : System.Address); - -- Set the address of the string containing the expanded name - -- 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. - procedure Set_RC_Offset (T : Tag; Value : SSE.Storage_Offset); -- Sets the Offset of the implicit record controller when the object -- has controlled components. Set to O otherwise. @@ -306,6 +342,18 @@ private -- Set to true if the type has been declared in a context described -- in E.4 (18). + procedure Set_SSD (T : Tag; Value : System.Address); + -- Given a pointer T to a dispatch Table, stores the pointer to the record + -- containing the Select Specific Data generated by GNAT. + + procedure Set_Tagged_Kind (T : Tag; Value : Tagged_Kind); + -- Set the tagged kind of a type in either a primary or a secondary + -- dispatch table denoted by T. + + 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. + function SSD (T : Tag) return Select_Specific_Data_Ptr; -- Given a pointer T to a dispatch Table, retrieves the address of the -- record containing the Select Specific Data in T's TSD. @@ -315,33 +363,31 @@ private -- record containing the Type Specific Data generated by GNAT. DT_Prologue_Size : constant SSE.Storage_Count := - SSE.Storage_Count - (3 * (Standard'Address_Size / System.Storage_Unit)); + SSE.Storage_Count (4 * (Standard'Address_Size / System.Storage_Unit)); -- Size of the first part of the dispatch table DT_Signature_Size : constant SSE.Storage_Count := - SSE.Storage_Count - (Standard'Address_Size / System.Storage_Unit); + SSE.Storage_Count (1 * (Standard'Address_Size / System.Storage_Unit)); -- Size of the Signature field of the dispatch table + DT_Tagged_Kind_Size : constant SSE.Storage_Count := + SSE.Storage_Count (1 * (Standard'Address_Size / System.Storage_Unit)); + -- Size of the Tagged_Type_Kind field of the dispatch table + DT_Offset_To_Top_Size : constant SSE.Storage_Count := - SSE.Storage_Count - (Standard'Address_Size / System.Storage_Unit); + SSE.Storage_Count (1 * (Standard'Address_Size / System.Storage_Unit)); -- Size of the Offset_To_Top field of the Dispatch Table DT_Typeinfo_Ptr_Size : constant SSE.Storage_Count := - SSE.Storage_Count - (Standard'Address_Size / System.Storage_Unit); + SSE.Storage_Count (1 * (Standard'Address_Size / System.Storage_Unit)); -- Size of the Typeinfo_Ptr field of the Dispatch Table DT_Entry_Size : constant SSE.Storage_Count := - SSE.Storage_Count - (1 * (Standard'Address_Size / System.Storage_Unit)); + SSE.Storage_Count (1 * (Standard'Address_Size / System.Storage_Unit)); -- Size of each primitive operation entry in the Dispatch Table TSD_Prologue_Size : constant SSE.Storage_Count := - SSE.Storage_Count - (10 * (Standard'Address_Size / System.Storage_Unit)); + SSE.Storage_Count (10 * (Standard'Address_Size / System.Storage_Unit)); -- Size of the first part of the type specific data TSD_Entry_Size : constant SSE.Storage_Count := @@ -396,6 +442,9 @@ private function To_Address is new Unchecked_Conversion (Type_Specific_Data_Ptr, System.Address); + function To_Interface_Data_Ptr is + new Unchecked_Conversion (System.Address, Interface_Data_Ptr); + function To_Object_Specific_Data_Ptr is new Unchecked_Conversion (System.Address, Object_Specific_Data_Ptr); @@ -409,10 +458,14 @@ private function To_Tag_Ptr is new Unchecked_Conversion (System.Address, Tag_Ptr); + function To_Tagged_Kind_Ptr is + new Unchecked_Conversion (System.Address, Tagged_Kind_Ptr); + -- Primitive dispatching operations are always inlined, to facilitate -- use in a minimal/no run-time environment for high integrity use. pragma Inline_Always (CW_Membership); + pragma Inline_Always (Displace); pragma Inline_Always (IW_Membership); pragma Inline_Always (Get_Access_Level); pragma Inline_Always (Get_Entry_Index); @@ -421,6 +474,7 @@ private pragma Inline_Always (Get_Prim_Op_Kind); pragma Inline_Always (Get_RC_Offset); pragma Inline_Always (Get_Remotely_Callable); + pragma Inline_Always (Get_Tagged_Kind); pragma Inline_Always (Inherit_DT); pragma Inline_Always (Inherit_TSD); pragma Inline_Always (OSD); @@ -430,6 +484,7 @@ private pragma Inline_Always (Set_Entry_Index); pragma Inline_Always (Set_Expanded_Name); pragma Inline_Always (Set_External_Tag); + pragma Inline_Always (Set_Interface_Table); pragma Inline_Always (Set_Num_Prim_Ops); pragma Inline_Always (Set_Offset_Index); pragma Inline_Always (Set_Offset_To_Top); @@ -440,6 +495,7 @@ private pragma Inline_Always (Set_OSD); pragma Inline_Always (Set_SSD); pragma Inline_Always (Set_TSD); + pragma Inline_Always (Set_Tagged_Kind); pragma Inline_Always (SSD); pragma Inline_Always (TSD); diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 3feb7d33aaa..6a975e6d68a 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -1760,20 +1760,18 @@ package body Exp_Ch3 is procedure Init_Secondary_Tags_Internal (Typ : Entity_Id) is E : Entity_Id; Aux_N : Node_Id; + Iface : Entity_Id; begin - if not Is_Interface (Typ) then + -- Climb to the ancestor (if any) handling private types - -- Climb to the ancestor (if any) handling private types - - if Present (Full_View (Etype (Typ))) then - if Full_View (Etype (Typ)) /= Typ then - Init_Secondary_Tags_Internal (Full_View (Etype (Typ))); - end if; - - elsif Etype (Typ) /= Typ then - Init_Secondary_Tags_Internal (Etype (Typ)); + if Present (Full_View (Etype (Typ))) then + if Full_View (Etype (Typ)) /= Typ then + Init_Secondary_Tags_Internal (Full_View (Etype (Typ))); end if; + + elsif Etype (Typ) /= Typ then + Init_Secondary_Tags_Internal (Etype (Typ)); end if; if Present (Abstract_Interfaces (Typ)) @@ -1787,6 +1785,8 @@ package body Exp_Ch3 is Aux_N := Node (ADT); pragma Assert (Present (Aux_N)); + Iface := Find_Interface (Typ, E); + -- Initialize the pointer to the secondary DT -- associated with the interface @@ -1801,15 +1801,23 @@ package body Exp_Ch3 is New_Reference_To (Aux_N, Loc))); -- Generate: - -- Set_Offset_To_Top (DT_Ptr, n); + -- Set_Offset_To_Top (Init, Iface'Tag, n); Append_To (Body_Stmts, Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (RTE (RE_Set_Offset_To_Top), Loc), Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Attribute_Name => Name_Address), + Unchecked_Convert_To (RTE (RE_Tag), - New_Reference_To (Aux_N, Loc)), + New_Reference_To + (Node (First_Elmt + (Access_Disp_Table (Iface))), + Loc)), + Unchecked_Convert_To (RTE (RE_Storage_Offset), Make_Attribute_Reference (Loc, Prefix => @@ -2118,7 +2126,9 @@ package body Exp_Ch3 is -- Case of composite component with its own Init_Proc - elsif Has_Non_Null_Base_Init_Proc (Typ) then + elsif not Is_Interface (Typ) + and then Has_Non_Null_Base_Init_Proc (Typ) + then Stmts := Build_Initialization_Call (Loc, @@ -4743,18 +4753,15 @@ package body Exp_Ch3 is Append_Freeze_Actions (Def_Id, Predef_List); -- Populate the two auxiliary tables used for dispatching - -- asynchronous, conditional and timed selects for tagged + -- asynchronous, conditional and timed selects for synchronized -- 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_Interface - (Typ => Def_Id, - Kind => Any_Limited_Interface, - Check_Parent => True) + and then Is_Concurrent_Record_Type (Def_Id) + and then Implements_Interface ( + Typ => Def_Id, + Kind => Any_Limited_Interface, + Check_Parent => True) then Append_Freeze_Actions (Def_Id, Make_Select_Specific_Data_Table (Def_Id)); @@ -5950,26 +5957,25 @@ package body Exp_Ch3 is end if; -- Generate the declarations for the following primitive operations: + -- disp_asynchronous_select -- disp_conditional_select -- disp_get_prim_op_kind -- disp_get_task_id -- disp_timed_select - -- for limited interfaces and tagged types that implement a limited - -- interface. + + -- for limited interfaces and synchronized 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_Interface - (Typ => Tag_Typ, - Kind => Any_Limited_Interface, - Check_Parent => True))) + ((Is_Interface (Tag_Typ) and then Is_Limited_Record (Tag_Typ)) + or else + (Is_Concurrent_Record_Type (Tag_Typ) + and then Implements_Interface ( + Typ => Tag_Typ, + Kind => Any_Limited_Interface, + Check_Parent => True))) then Append_To (Res, Make_Subprogram_Declaration (Loc, @@ -6360,20 +6366,18 @@ package body Exp_Ch3 is -- disp_get_task_id -- disp_timed_select - -- for limited interfaces and tagged types that implement a limited - -- interface. The interface versions will have null bodies. + -- for limited interfaces and synchronized types that implement a + -- limited interface. The interface versions will have null bodies. 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_Interface - (Typ => Tag_Typ, - Kind => Any_Limited_Interface, - Check_Parent => True))) + (Is_Concurrent_Record_Type (Tag_Typ) + and then Implements_Interface ( + Typ => Tag_Typ, + Kind => Any_Limited_Interface, + Check_Parent => True))) then Append_To (Res, Make_Disp_Asynchronous_Select_Body (Tag_Typ)); Append_To (Res, Make_Disp_Conditional_Select_Body (Tag_Typ)); diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 76dde0e73cb..bb9407c7ffb 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -4289,8 +4289,7 @@ package body Exp_Ch6 is Expand_Interface_Thunk (N => Prim, Thunk_Alias => Alias (Prim), - Thunk_Id => Thunk_Id, - Thunk_Tag => Iface_Tag); + Thunk_Id => Thunk_Id); Insert_After (N, New_Thunk); @@ -4341,8 +4340,7 @@ package body Exp_Ch6 is Expand_Interface_Thunk (N => Ancestor_Iface_Prim, Thunk_Alias => Prim_Op, - Thunk_Id => Thunk_Id, - Thunk_Tag => Iface_Tag); + Thunk_Id => Thunk_Id); Insert_After (N, New_Thunk); @@ -4401,8 +4399,7 @@ package body Exp_Ch6 is Expand_Interface_Thunk (N => Prim, Thunk_Alias => Prim, - Thunk_Id => Thunk_Id, - Thunk_Tag => Iface_Tag); + Thunk_Id => Thunk_Id); Insert_After (N, New_Thunk); Insert_After (New_Thunk, diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 3943dc4dbc0..310278d62e0 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -33,6 +33,7 @@ with Exp_Ch3; use Exp_Ch3; with Exp_Ch11; use Exp_Ch11; with Exp_Ch6; use Exp_Ch6; with Exp_Dbug; use Exp_Dbug; +with Exp_Sel; use Exp_Sel; with Exp_Smem; use Exp_Smem; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; @@ -61,10 +62,6 @@ with Uintp; use Uintp; package body Exp_Ch9 is - -------------------------------- - -- Select_Expansion_Utilities -- - -------------------------------- - -- The following constant establishes the upper bound for the index of -- an entry family. It is used to limit the allocated size of protected -- types with defaulted discriminant of an integer type, when the bound @@ -75,232 +72,6 @@ package body Exp_Ch9 is Entry_Family_Bound : constant Int := 2**16; - -- 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; - Abr_Blk_Ent : Entity_Id; - Cln_Blk_Ent : Entity_Id; - Blk : Node_Id) return Node_Id; - -- Generate: - -- begin - -- Blk - -- exception - -- when Abort_Signal => Abort_Undefer; - -- end; - -- Abr_Blk_Ent is the name of the generated block, Cln_Blk_Ent is - -- the name of the encapsulated cleanup 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; - Obj : Entity_Id; - Call_Ent : Entity_Id) return Entity_Id; - -- Generate: - -- S : constant Integer := - -- Ada.Tags.Get_Offset_Index ( - -- Unchecked_Convert_To (Ada.Tags.Interface_Tag, Obj), - -- DT_Position (Call_Ent)); - -- where Obj is the pointer to a secondary table, Call_Ent is the - -- entity of the dispatching call name. Append the object declaration - -- to the list and return its defining identifier. - - end Select_Expansion_Utilities; - - ----------------------------------------- - -- Body for Select_Expansion_Utilities -- - ----------------------------------------- - - package body Select_Expansion_Utilities is - - ----------------------- - -- Build_Abort_Block -- - ----------------------- - - function Build_Abort_Block - (Loc : Source_Ptr; - Abr_Blk_Ent : Entity_Id; - Cln_Blk_Ent : Entity_Id; - Blk : Node_Id) return Node_Id - is - begin - return - Make_Block_Statement (Loc, - Identifier => New_Reference_To (Abr_Blk_Ent, Loc), - - Declarations => No_List, - - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => - New_List ( - Make_Implicit_Label_Declaration (Loc, - Defining_Identifier => - Cln_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, - Chars => New_Internal_Name ('B')); - - 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, - Chars => New_Internal_Name ('C')); - - 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; - Obj : Entity_Id; - Call_Ent : Entity_Id) return Entity_Id - is - S : constant Entity_Id := Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('S')); - - begin - Append_To (Decls, - Make_Object_Declaration (Loc, - Defining_Identifier => S, - Constant_Present => True, - - Object_Definition => - New_Reference_To (Standard_Integer, Loc), - - Expression => - Make_Function_Call (Loc, - Name => New_Reference_To (RTE (RE_Get_Offset_Index), Loc), - Parameter_Associations => New_List ( - Unchecked_Convert_To (RTE (RE_Interface_Tag), Obj), - Make_Integer_Literal (Loc, DT_Position (Call_Ent)))))); - - return S; - end Build_S; - end Select_Expansion_Utilities; - - package SEU renames Select_Expansion_Utilities; - ----------------------- -- Local Subprograms -- ----------------------- @@ -2210,6 +1981,7 @@ package body Exp_Ch9 is if Abort_Allowed or else Restriction_Active (No_Entry_Queue) = False or else Number_Entries (Pid) > 1 + or else (Has_Attach_Handler (Pid) and then not Restricted_Profile) then Complete := New_Reference_To (RTE (RE_Complete_Entry_Body), Loc); else @@ -2251,6 +2023,7 @@ package body Exp_Ch9 is if Abort_Allowed or else Restriction_Active (No_Entry_Queue) = False or else Number_Entries (Pid) > 1 + or else (Has_Attach_Handler (Pid) and then not Restricted_Profile) then Complete := New_Reference_To (RTE (RE_Exceptional_Complete_Entry_Body), Loc); @@ -2660,6 +2433,7 @@ package body Exp_Ch9 is if Abort_Allowed or else Restriction_Active (No_Entry_Queue) = False or else Number_Entries (Pid) > 1 + or else (Has_Attach_Handler (Pid) and then not Restricted_Profile) then Lock_Name := New_Reference_To (RTE (RE_Lock_Entries), Loc); Service_Name := New_Reference_To (RTE (RE_Service_Entries), Loc); @@ -2994,6 +2768,8 @@ package body Exp_Ch9 is or else Restriction_Active (No_Entry_Queue) = False or else not Is_Protected_Type (Conctyp) or else Number_Entries (Conctyp) > 1 + or else (Has_Attach_Handler (Conctyp) + and then not Restricted_Profile) then X := Make_Defining_Identifier (Loc, Name_uX); @@ -3133,6 +2909,8 @@ package body Exp_Ch9 is if Abort_Allowed or else Restriction_Active (No_Entry_Queue) = False or else Number_Entries (Conctyp) > 1 + or else (Has_Attach_Handler (Conctyp) + and then not Restricted_Profile) then -- Change the type of the index declaration @@ -4898,86 +4676,98 @@ package body Exp_Ch9 is -- 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; - - -- 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 - -- <abortable-statements> - -- end if; - -- at end - -- _clean; - -- end; - -- exception - -- when Abort_Signal => Abort_Undefer; - -- end; - - -- if not Cancelled (Bnn) then - -- <triggering-statements> - -- end if; - - -- elsif C = POK_Task_Entry then - -- declare - -- procedure _clean is - -- begin - -- Cancel_Task_Entry_Call (U); - -- end _clean; - - -- begin - -- Abort_Defer; - - -- disp_asynchronous_select - -- (<object>, S, P'address, Bnn, B); + -- declare + -- B : Boolean := False; + -- Bnn : Communication_Block; + -- C : Ada.Tags.Prim_Op_Kind; + -- K : Ada.Tags.Tagged_Kind := + -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>)); + -- P : Parameters := (Param1 .. ParamN); + -- S : Integer; + -- U : Boolean; - -- Param1 := P.Param1; - -- ... - -- ParamN := P.ParamN; - - -- begin - -- begin - -- Abort_Undefer; - -- <abortable-statements> - -- at end - -- _clean; - -- end; - -- exception - -- when Abort_Signal => Abort_Undefer; - -- end; - - -- if not U then - -- <triggering-statements> - -- end if; - -- end; + -- begin + -- if K = Ada.Tags.TK_Limited_Tagged then + -- <dispatching-call>; + -- <triggering-statements>; - -- else - -- <dispatching-call>; - -- <triggering-statements> - -- end if; + -- else + -- S := Ada.Tags.Get_Offset_Index (Ada.Tags.Tag (<object>), + -- DT_Position (<dispatching-call>)); + + -- _Disp_Get_Prim_Op_Kind (<object>, S, C); + + -- if C = POK_Protected_Entry then + -- declare + -- procedure _clean is + -- begin + -- if Enqueued (Bnn) then + -- Cancel_Protected_Entry_Call (Bnn); + -- end if; + -- end _clean; + + -- begin + -- begin + -- _Disp_Asynchronous_Select + -- (<object>, S, P'address, Bnn, B); + + -- Param1 := P.Param1; + -- ... + -- ParamN := P.ParamN; + + -- if Enqueued (Bnn) then + -- <abortable-statements> + -- end if; + -- at end + -- _clean; + -- end; + -- exception + -- when Abort_Signal => Abort_Undefer; + -- end; + + -- if not Cancelled (Bnn) then + -- <triggering-statements> + -- end if; + + -- elsif C = POK_Task_Entry then + -- declare + -- procedure _clean is + -- begin + -- Cancel_Task_Entry_Call (U); + -- end _clean; + + -- begin + -- Abort_Defer; + + -- _Disp_Asynchronous_Select + -- (<object>, S, P'address, Bnn, B); + + -- Param1 := P.Param1; + -- ... + -- ParamN := P.ParamN; + + -- begin + -- begin + -- Abort_Undefer; + -- <abortable-statements> + -- at end + -- _clean; + -- end; + -- exception + -- when Abort_Signal => Abort_Undefer; + -- end; + + -- if not U then + -- <triggering-statements> + -- end if; + -- end; + + -- else + -- <dispatching-call>; + -- <triggering-statements> + -- end if; + -- end if; + -- end; -- The job is to convert this to the asynchronous form @@ -5011,6 +4801,7 @@ package body Exp_Ch9 is Cleanup_Block : Node_Id; Cleanup_Block_Ent : Entity_Id; Cleanup_Stmts : List_Id; + Conc_Typ_Stmts : List_Id; Concval : Node_Id; Dblock_Ent : Entity_Id; Decl : Node_Id; @@ -5021,6 +4812,7 @@ package body Exp_Ch9 is Formals : List_Id; Hdle : List_Id; Index : Node_Id; + Lim_Typ_Stmts : List_Id; N_Orig : Node_Id; Obj : Entity_Id; Param : Node_Id; @@ -5037,6 +4829,7 @@ package body Exp_Ch9 is B : Entity_Id; -- Call status flag Bnn : Entity_Id; -- Communication block C : Entity_Id; -- Call kind + K : Entity_Id; -- Tagged kind P : Entity_Id; -- Parameter block S : Entity_Id; -- Primitive operation slot T : Entity_Id; -- Additional status flag @@ -5077,7 +4870,7 @@ package body Exp_Ch9 is -- Call status flag processing, generate: -- B : Boolean := False; - B := SEU.Build_B (Loc, Decls); + B := Build_B (Loc, Decls); -- Communication block processing, generate: -- Bnn : Communication_Block; @@ -5094,7 +4887,13 @@ package body Exp_Ch9 is -- Call kind processing, generate: -- C : Ada.Tags.Prim_Op_Kind; - C := SEU.Build_C (Loc, Decls); + C := Build_C (Loc, Decls); + + -- Tagged kind processing, generate: + -- K : Ada.Tags.Tagged_Kind := + -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>)); + + K := Build_K (Loc, Decls, Obj); -- Parameter block processing @@ -5104,12 +4903,9 @@ package body Exp_Ch9 is (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts); -- Dispatch table slot processing, generate: - -- S : constant Integer := - -- Ada.Tags.Get_Offset_Index ( - -- Unchecked_Convert_To (Ada.Tags.Interface_Tag, Obj), - -- DT_Position (<dispatching-procedure>)); + -- S : Integer; - S := SEU.Build_S (Loc, Decls, Obj, Call_Ent); + S := Build_S (Loc, Decls); -- Additional status flag processing, generate: @@ -5122,19 +4918,6 @@ package body Exp_Ch9 is Object_Definition => New_Reference_To (Standard_Boolean, Loc))); - Append_To (Stmts, - Make_Procedure_Call_Statement (Loc, - Name => - New_Reference_To ( - Find_Prim_Op (Etype (Etype (Obj)), - Name_uDisp_Get_Prim_Op_Kind), - Loc), - Parameter_Associations => - New_List ( - New_Copy_Tree (Obj), - New_Reference_To (S, Loc), - New_Reference_To (C, Loc)))); - -- --------------------------------------------------------------- -- Protected entry handling @@ -5146,8 +4929,7 @@ package body Exp_Ch9 is Cleanup_Stmts := Parameter_Block_Unpack (Loc, P, Actuals, Formals); -- Generate: - -- _dispatching_asynchronous_select - -- (<object>, S, P'address, Bnn, B); + -- _Disp_Asynchronous_Select (<object>, S, P'address, Bnn, B); Prepend_To (Cleanup_Stmts, Make_Procedure_Call_Statement (Loc, @@ -5155,7 +4937,7 @@ package body Exp_Ch9 is New_Reference_To ( Find_Prim_Op (Etype (Etype (Obj)), Name_uDisp_Asynchronous_Select), - Loc), + Loc), Parameter_Associations => New_List ( New_Copy_Tree (Obj), @@ -5204,8 +4986,8 @@ package body Exp_Ch9 is Cleanup_Block_Ent := Make_Defining_Identifier (Loc, New_Internal_Name ('C')); - Cleanup_Block := SEU.Build_Cleanup_Block (Loc, - Cleanup_Block_Ent, Cleanup_Stmts, Bnn); + Cleanup_Block := + Build_Cleanup_Block (Loc, Cleanup_Block_Ent, Cleanup_Stmts, Bnn); -- Wrap the cleanup block in an exception handling block @@ -5224,8 +5006,8 @@ package body Exp_Ch9 is Make_Implicit_Label_Declaration (Loc, Defining_Identifier => Abort_Block_Ent), - SEU.Build_Abort_Block (Loc, - Abort_Block_Ent, Cleanup_Block_Ent, Cleanup_Block)); + Build_Abort_Block + (Loc, Abort_Block_Ent, Cleanup_Block_Ent, Cleanup_Block)); -- Generate: -- if not Cancelled (Bnn) then @@ -5258,8 +5040,7 @@ package body Exp_Ch9 is TaskE_Stmts := Parameter_Block_Unpack (Loc, P, Actuals, Formals); -- Generate: - -- _dispatching_asynchronous_select - -- (<object>, S, P'address, Bnn, B); + -- _Disp_Asynchronous_Select (<object>, S, P'address, Bnn, B); Prepend_To (TaskE_Stmts, Make_Procedure_Call_Statement (Loc, @@ -5267,7 +5048,7 @@ package body Exp_Ch9 is New_Reference_To ( Find_Prim_Op (Etype (Etype (Obj)), Name_uDisp_Asynchronous_Select), - Loc), + Loc), Parameter_Associations => New_List ( New_Copy_Tree (Obj), @@ -5319,8 +5100,8 @@ package body Exp_Ch9 is Cleanup_Block_Ent := Make_Defining_Identifier (Loc, New_Internal_Name ('C')); - Cleanup_Block := SEU.Build_Cleanup_Block (Loc, - Cleanup_Block_Ent, Cleanup_Stmts, T); + Cleanup_Block := + Build_Cleanup_Block (Loc, Cleanup_Block_Ent, Cleanup_Stmts, T); -- Wrap the cleanup block in an exception handling block @@ -5339,8 +5120,8 @@ package body Exp_Ch9 is Defining_Identifier => Abort_Block_Ent)); Append_To (TaskE_Stmts, - SEU.Build_Abort_Block (Loc, - Abort_Block_Ent, Cleanup_Block_Ent, Cleanup_Block)); + Build_Abort_Block + (Loc, Abort_Block_Ent, Cleanup_Block_Ent, Cleanup_Block)); -- Generate: -- if not T then @@ -5368,6 +5149,29 @@ package body Exp_Ch9 is Prepend_To (ProtP_Stmts, New_Copy_Tree (Ecall)); -- Generate: + -- S := Ada.Tags.Get_Offset_Index ( + -- Ada.Tags.Tag (<object>), DT_Position (Call_Ent)); + + Conc_Typ_Stmts := New_List ( + Build_S_Assignment (Loc, S, Obj, Call_Ent)); + + -- Generate: + -- _Disp_Get_Prim_Op_Kind (<object>, S, C); + + Append_To (Conc_Typ_Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To ( + Find_Prim_Op (Etype (Etype (Obj)), + Name_uDisp_Get_Prim_Op_Kind), + Loc), + Parameter_Associations => + New_List ( + New_Copy_Tree (Obj), + New_Reference_To (S, Loc), + New_Reference_To (C, Loc)))); + + -- Generate: -- if C = POK_Procedure_Entry then -- ProtE_Stmts -- elsif C = POK_Task_Entry then @@ -5376,7 +5180,7 @@ package body Exp_Ch9 is -- ProtP_Stmts -- end if; - Append_To (Stmts, + Append_To (Conc_Typ_Stmts, Make_If_Statement (Loc, Condition => Make_Op_Eq (Loc, @@ -5404,6 +5208,35 @@ package body Exp_Ch9 is Else_Statements => ProtP_Stmts)); + -- Generate: + -- <dispatching-call>; + -- <triggering-statements> + + Lim_Typ_Stmts := New_Copy_List_Tree (Tstats); + Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (Ecall)); + + -- Generate: + -- if K = Ada.Tags.TK_Limited_Tagged then + -- Lim_Typ_Stmts + -- else + -- Conc_Typ_Stmts + -- end if; + + Append_To (Stmts, + Make_If_Statement (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => + New_Reference_To (K, Loc), + Right_Opnd => + New_Reference_To (RTE (RE_TK_Limited_Tagged), Loc)), + + Then_Statements => + Lim_Typ_Stmts, + + Else_Statements => + Conc_Typ_Stmts)); + Rewrite (N, Make_Block_Statement (Loc, Declarations => @@ -5866,30 +5699,42 @@ package body Exp_Ch9 is -- declare -- B : Boolean := False; -- C : Ada.Tags.Prim_Op_Kind; + -- K : Ada.Tags.Tagged_Kind := + -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>)); -- P : Parameters := (Param1 .. ParamN); - -- S : constant Integer := DT_Position (<dispatching-procedure>); + -- S : Integer; -- begin - -- disp_conditional_select (<object>, S, P'address, C, B); + -- if K = Ada.Tags.TK_Limited_Tagged then + -- <dispatching-call>; + -- <triggering-statements> - -- if C = POK_Protected_Entry - -- or else C = POK_Task_Entry - -- then - -- Param1 := P.Param1; - -- ... - -- ParamN := P.ParamN; - -- end if; + -- else + -- S := Ada.Tags.Get_Offset_Index (Ada.Tags.Tag (<object>), + -- DT_Position (<dispatching-call>)); - -- if B then - -- if C = POK_Procedure - -- or else C = POK_Protected_Procedure - -- or else C = POK_Task_Procedure + -- _Disp_Conditional_Select (<object>, S, P'address, C, B); + + -- if C = POK_Protected_Entry + -- or else C = POK_Task_Entry -- then - -- <dispatching-procedure> (<object>, Param1 .. ParamN); + -- Param1 := P.Param1; + -- ... + -- ParamN := P.ParamN; + -- end if; + + -- if B then + -- if C = POK_Procedure + -- or else C = POK_Protected_Procedure + -- or else C = POK_Task_Procedure + -- then + -- <dispatching-call>; + -- end if; + + -- <triggering-statements> + -- else + -- <else-statements> -- end if; - -- <normal-statements> - -- else - -- <else-statements> -- end if; -- end; @@ -5899,25 +5744,28 @@ package body Exp_Ch9 is Blk : Node_Id := Entry_Call_Statement (Alt); Transient_Blk : 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; - Unpack : List_Id; - - B : Entity_Id; -- Call status flag - C : Entity_Id; -- Call kind - P : Entity_Id; -- Parameter block - S : Entity_Id; -- Primitive operation slot + Actuals : List_Id; + Blk_Typ : Entity_Id; + Call : Node_Id; + Call_Ent : Entity_Id; + Conc_Typ_Stmts : List_Id; + Decl : Node_Id; + Decls : List_Id; + Formals : List_Id; + Lim_Typ_Stmts : List_Id; + N_Stats : List_Id; + Obj : Entity_Id; + Param : Node_Id; + Params : List_Id; + Stmt : Node_Id; + Stmts : List_Id; + Unpack : List_Id; + + B : Entity_Id; -- Call status flag + C : Entity_Id; -- Call kind + K : Entity_Id; -- Tagged kind + P : Entity_Id; -- Parameter block + S : Entity_Id; -- Primitive operation slot begin if Ada_Version >= Ada_05 @@ -5931,31 +5779,41 @@ package body Exp_Ch9 is -- Call status flag processing, generate: -- B : Boolean := False; - B := SEU.Build_B (Loc, Decls); + B := Build_B (Loc, Decls); -- Call kind processing, generate: -- C : Ada.Tags.Prim_Op_Kind; - C := SEU.Build_C (Loc, Decls); + C := Build_C (Loc, Decls); + + -- Tagged kind processing, generate: + -- K : Ada.Tags.Tagged_Kind := + -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>)); + + K := Build_K (Loc, Decls, Obj); -- Parameter block processing Blk_Typ := Build_Parameter_Block (Loc, Actuals, Formals, Decls); - P := Parameter_Block_Pack (Loc, Blk_Typ, Actuals, Formals, - Decls, Stmts); + P := Parameter_Block_Pack + (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts); -- Dispatch table slot processing, generate: - -- S : constant Integer := - -- Ada.Tags.Get_Offset_Index ( - -- Unchecked_Convert_To (Ada.Tags.Interface_Tag, Obj), - -- DT_Position (<dispatching-procedure>)); + -- S : Integer; - S := SEU.Build_S (Loc, Decls, Obj, Call_Ent); + S := Build_S (Loc, Decls); -- Generate: - -- _dispatching_conditional_select (<object>, S, P'address, C, B); + -- S := Ada.Tags.Get_Offset_Index ( + -- Ada.Tags.Tag (<object>), DT_Position (Call_Ent)); - Append_To (Stmts, + Conc_Typ_Stmts := New_List ( + Build_S_Assignment (Loc, S, Obj, Call_Ent)); + + -- Generate: + -- _Disp_Conditional_Select (<object>, S, P'address, C, B); + + Append_To (Conc_Typ_Stmts, Make_Procedure_Call_Statement (Loc, Name => New_Reference_To ( @@ -5987,7 +5845,7 @@ package body Exp_Ch9 is -- explicit assignments to their corresponding actuals. if Present (Unpack) then - Append_To (Stmts, + Append_To (Conc_Typ_Stmts, Make_If_Statement (Loc, Condition => @@ -6006,7 +5864,8 @@ package body Exp_Ch9 is Right_Opnd => New_Reference_To (RTE (RE_POK_Task_Entry), Loc))), - Then_Statements => Unpack)); + Then_Statements => + Unpack)); end if; -- Generate: @@ -6015,7 +5874,7 @@ package body Exp_Ch9 is -- or else C = POK_Protected_Procedure -- or else C = POK_Task_Procedure -- then - -- <dispatching-procedure-call> + -- <dispatching-call> -- end if; -- <normal-statements> -- else @@ -6056,12 +5915,41 @@ package body Exp_Ch9 is Then_Statements => New_List (Blk))); - Append_To (Stmts, + Append_To (Conc_Typ_Stmts, Make_If_Statement (Loc, Condition => New_Reference_To (B, Loc), Then_Statements => N_Stats, Else_Statements => Else_Statements (N))); + -- Generate: + -- <dispatching-call>; + -- <triggering-statements> + + Lim_Typ_Stmts := New_Copy_List_Tree (Statements (Alt)); + Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (Blk)); + + -- Generate: + -- if K = Ada.Tags.TK_Limited_Tagged then + -- Lim_Typ_Stmts + -- else + -- Conc_Typ_Stmts + -- end if; + + Append_To (Stmts, + Make_If_Statement (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => + New_Reference_To (K, Loc), + Right_Opnd => + New_Reference_To (RTE (RE_TK_Limited_Tagged), Loc)), + + Then_Statements => + Lim_Typ_Stmts, + + Else_Statements => + Conc_Typ_Stmts)); + Rewrite (N, Make_Block_Statement (Loc, Declarations => Decls, @@ -6771,8 +6659,10 @@ package body Exp_Ch9 is if Has_Entries and then (Abort_Allowed - or else Restriction_Active (No_Entry_Queue) = False - or else Num_Entries > 1) + or else Restriction_Active (No_Entry_Queue) = False + or else Num_Entries > 1 + or else (Has_Attach_Handler (Pid) + and then not Restricted_Profile)) then New_Op_Body := Build_Find_Body_Index (Pid); Insert_After (Current_Node, New_Op_Body); @@ -7494,6 +7384,8 @@ package body Exp_Ch9 is if Abort_Allowed or else Restriction_Active (No_Entry_Queue) = False or else E_Count > 1 + or else (Has_Attach_Handler (Prottyp) + and then not Restricted_Profile) then Body_Arr := Make_Object_Declaration (Loc, Defining_Identifier => Body_Id, @@ -7543,6 +7435,8 @@ package body Exp_Ch9 is if Abort_Allowed or else Restriction_Active (No_Entry_Queue) = False or else E_Count > 1 + or else (Has_Attach_Handler (Prottyp) + and then not Restricted_Profile) then Sub := Make_Subprogram_Declaration (Loc, @@ -9538,31 +9432,43 @@ package body Exp_Ch9 is -- B : Boolean := False; -- C : Ada.Tags.Prim_Op_Kind; -- DX : Duration := To_Duration (D) + -- K : Ada.Tags.Tagged_Kind := + -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>)); -- M : Integer :=...; -- P : Parameters := (Param1 .. ParamN); - -- S : constant Iteger := DT_Position (<dispatching-procedure>); + -- S : Iteger; -- begin - -- disp_timed_select (<object>, S, P'Address, DX, M, C, B); + -- if K = Ada.Tags.TK_Limited_Tagged then + -- <dispatching-call>; + -- <triggering-statements> - -- if C = POK_Protected_Entry - -- or else C = POK_Task_Entry - -- then - -- Param1 := P.Param1; - -- ... - -- ParamN := P.ParamN; - -- end if; + -- else + -- S := Ada.Tags.Get_Offset_Index (Ada.Tags.Tag (<object>), + -- DT_Position (<dispatching-call>)); - -- if B then - -- if C = POK_Procedure - -- or else C = POK_Protected_Procedure - -- or else C = POK_Task_Procedure + -- _Disp_Timed_Select (<object>, S, P'Address, DX, M, C, B); + + -- if C = POK_Protected_Entry + -- or else C = POK_Task_Entry -- then - -- T.E; + -- Param1 := P.Param1; + -- ... + -- ParamN := P.ParamN; + -- end if; + + -- if B then + -- if C = POK_Procedure + -- or else C = POK_Protected_Procedure + -- or else C = POK_Task_Procedure + -- then + -- <dispatching-call>; + -- end if; + + -- <triggering-statements> + -- else + -- <timed-statements> -- end if; - -- S1; - -- else - -- S2; -- end if; -- end; @@ -9578,30 +9484,33 @@ package body Exp_Ch9 is D_Stats : constant List_Id := Statements (Delay_Alternative (N)); - 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; - Unpack : List_Id; + Actuals : List_Id; + Blk_Typ : Entity_Id; + Call : Node_Id; + Call_Ent : Entity_Id; + Conc_Typ_Stmts : List_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; + Lim_Typ_Stmts : List_Id; + N_Stats : List_Id; + Obj : Entity_Id; + Param : Node_Id; + Params : List_Id; + Stmt : Node_Id; + Stmts : List_Id; + Unpack : List_Id; B : Entity_Id; -- Call status flag C : Entity_Id; -- Call kind D : Entity_Id; -- Delay + K : Entity_Id; -- Tagged kind M : Entity_Id; -- Delay mode P : Entity_Id; -- Parameter block S : Entity_Id; -- Primitive operation slot @@ -9651,7 +9560,7 @@ package body Exp_Ch9 is -- Generate: -- B : Boolean := False; - B := SEU.Build_B (Loc, Decls); + B := Build_B (Loc, Decls); else -- Generate: @@ -9675,7 +9584,7 @@ package body Exp_Ch9 is -- Generate: -- C : Ada.Tags.Prim_Op_Kind; - C := SEU.Build_C (Loc, Decls); + C := Build_C (Loc, Decls); end if; -- Duration and mode processing @@ -9747,20 +9656,30 @@ package body Exp_Ch9 is if Ada_Version >= Ada_05 and then Nkind (E_Call) = N_Procedure_Call_Statement then + -- Tagged kind processing, generate: + -- K : Ada.Tags.Tagged_Kind := + -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag <object>)); + + K := Build_K (Loc, Decls, Obj); + Blk_Typ := Build_Parameter_Block (Loc, Actuals, Formals, Decls); P := Parameter_Block_Pack (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts); -- Dispatch table slot processing, generate: - -- S : constant Integer := - -- Ada.Tags.Get_Offset_Index ( - -- Unchecked_Convert_To (Ada.Tags.Interface_Tag, Obj), - -- DT_Position (<dispatching-procedure>)); + -- S : Integer; - S := SEU.Build_S (Loc, Decls, Obj, Call_Ent); + S := Build_S (Loc, Decls); -- Generate: - -- _dispatching_timed_select (Obj, S, P'address, D, M, C, B); + -- S := Ada.Tags.Get_Offset_Index ( + -- Ada.Tags.Tag (<object>), DT_Position (Call_Ent)); + + Conc_Typ_Stmts := New_List ( + Build_S_Assignment (Loc, S, Obj, Call_Ent)); + + -- Generate: + -- _Disp_Timed_Select (<object>, S, P'address, D, M, C, B); -- where Obj is the controlling formal parameter, S is the dispatch -- table slot number of the dispatching operation, P is the wrapped @@ -9779,7 +9698,7 @@ package body Exp_Ch9 is Append_To (Params, New_Reference_To (C, Loc)); Append_To (Params, New_Reference_To (B, Loc)); - Append_To (Stmts, + Append_To (Conc_Typ_Stmts, Make_Procedure_Call_Statement (Loc, Name => New_Reference_To ( @@ -9804,7 +9723,7 @@ package body Exp_Ch9 is -- explicit assignments to their corresponding actuals. if Present (Unpack) then - Append_To (Stmts, + Append_To (Conc_Typ_Stmts, Make_If_Statement (Loc, Condition => @@ -9823,7 +9742,8 @@ package body Exp_Ch9 is Right_Opnd => New_Reference_To (RTE (RE_POK_Task_Entry), Loc))), - Then_Statements => Unpack)); + Then_Statements => + Unpack)); end if; -- Generate: @@ -9833,11 +9753,11 @@ package body Exp_Ch9 is -- or else C = POK_Protected_Procedure -- or else C = POK_Task_Procedure -- then - -- <dispatching-procedure-call> + -- <dispatching-call> -- end if; - -- <normal-statements> + -- <triggering-statements> -- else - -- <delay-statements> + -- <timed-statements> -- end if; N_Stats := New_Copy_List_Tree (E_Stats); @@ -9873,11 +9793,41 @@ package body Exp_Ch9 is Then_Statements => New_List (E_Call))); - Append_To (Stmts, + Append_To (Conc_Typ_Stmts, Make_If_Statement (Loc, Condition => New_Reference_To (B, Loc), Then_Statements => N_Stats, Else_Statements => D_Stats)); + + -- Generate: + -- <dispatching-call>; + -- <triggering-statements> + + Lim_Typ_Stmts := New_Copy_List_Tree (E_Stats); + Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (E_Call)); + + -- Generate: + -- if K = Ada.Tags.TK_Limited_Tagged then + -- Lim_Typ_Stmts + -- else + -- Conc_Typ_Stmts + -- end if; + + Append_To (Stmts, + Make_If_Statement (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => + New_Reference_To (K, Loc), + Right_Opnd => + New_Reference_To (RTE (RE_TK_Limited_Tagged), Loc)), + + Then_Statements => + Lim_Typ_Stmts, + + Else_Statements => + Conc_Typ_Stmts)); + else -- Skip assignments to temporaries created for in-out parameters. -- This makes unwarranted assumptions about the shape of the expanded @@ -10579,6 +10529,7 @@ package body Exp_Ch9 is if Abort_Allowed or else Restriction_Active (No_Entry_Queue) = False or else Number_Entries (Ptyp) > 1 + or else (Has_Attach_Handler (Ptyp) and then not Restricted) then -- Find index mapping function (clumsy but ok for now) @@ -10601,6 +10552,8 @@ package body Exp_Ch9 is if Abort_Allowed or else Restriction_Active (No_Entry_Queue) = False or else Number_Entries (Ptyp) > 1 + or else (Has_Attach_Handler (Ptyp) + and then not Restricted) then Append_To (L, Make_Procedure_Call_Statement (Loc, diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 20e769e1804..e3daf07bfc4 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -309,11 +309,11 @@ package body Exp_Disp is Get_Access_Level => RE_Get_Access_Level, Get_Entry_Index => RE_Get_Entry_Index, Get_External_Tag => RE_Get_External_Tag, - Get_Offset_Index => RE_Get_Offset_Index, 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, + Get_Tagged_Kind => RE_Get_Tagged_Kind, Inherit_DT => RE_Inherit_DT, Inherit_TSD => RE_Inherit_TSD, Register_Interface_Tag => RE_Register_Interface_Tag, @@ -322,6 +322,7 @@ package body Exp_Disp is Set_Entry_Index => RE_Set_Entry_Index, Set_Expanded_Name => RE_Set_Expanded_Name, Set_External_Tag => RE_Set_External_Tag, + Set_Interface_Table => RE_Set_Interface_Table, Set_Offset_Index => RE_Set_Offset_Index, Set_OSD => RE_Set_OSD, Set_Prim_Op_Address => RE_Set_Prim_Op_Address, @@ -330,6 +331,7 @@ package body Exp_Disp is Set_Remotely_Callable => RE_Set_Remotely_Callable, Set_SSD => RE_Set_SSD, Set_TSD => RE_Set_TSD, + Set_Tagged_Kind => RE_Set_Tagged_Kind, TSD_Entry_Size => RE_TSD_Entry_Size, TSD_Prologue_Size => RE_TSD_Prologue_Size); @@ -341,11 +343,11 @@ package body Exp_Disp is Get_Access_Level => False, Get_Entry_Index => False, Get_External_Tag => False, - Get_Offset_Index => False, Get_Prim_Op_Address => False, Get_Prim_Op_Kind => False, - Get_Remotely_Callable => False, Get_RC_Offset => False, + Get_Remotely_Callable => False, + Get_Tagged_Kind => False, Inherit_DT => True, Inherit_TSD => True, Register_Interface_Tag => True, @@ -354,6 +356,7 @@ package body Exp_Disp is Set_Entry_Index => True, Set_Expanded_Name => True, Set_External_Tag => True, + Set_Interface_Table => True, Set_Offset_Index => True, Set_OSD => True, Set_Prim_Op_Address => True, @@ -362,6 +365,7 @@ package body Exp_Disp is Set_Remotely_Callable => True, Set_SSD => True, Set_TSD => True, + Set_Tagged_Kind => True, TSD_Entry_Size => False, TSD_Prologue_Size => False); @@ -373,19 +377,20 @@ package body Exp_Disp is Get_Access_Level => 1, Get_Entry_Index => 2, Get_External_Tag => 1, - Get_Offset_Index => 2, Get_Prim_Op_Address => 2, Get_Prim_Op_Kind => 2, Get_RC_Offset => 1, Get_Remotely_Callable => 1, + Get_Tagged_Kind => 1, Inherit_DT => 3, Inherit_TSD => 2, - Register_Interface_Tag => 2, + Register_Interface_Tag => 3, Register_Tag => 1, Set_Access_Level => 2, Set_Entry_Index => 3, Set_Expanded_Name => 2, Set_External_Tag => 2, + Set_Interface_Table => 2, Set_Offset_Index => 3, Set_OSD => 2, Set_Prim_Op_Address => 3, @@ -394,6 +399,7 @@ package body Exp_Disp is Set_Remotely_Callable => 2, Set_SSD => 2, Set_TSD => 2, + Set_Tagged_Kind => 2, TSD_Entry_Size => 0, TSD_Prologue_Size => 0); @@ -414,9 +420,13 @@ package body Exp_Disp is (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 + -- according to its type Typ. Return a reference to an RE_Prim_Op_Kind -- enumeration value. + function Tagged_Kind (T : Entity_Id) return Node_Id; + -- Ada 2005 (AI-345): Determine the tagged kind of T and return a reference + -- to an RE_Tagged_Kind enumeration value. + ---------------------------- -- Collect_All_Interfaces -- ---------------------------- @@ -426,7 +436,7 @@ package body Exp_Disp is procedure Add_Interface (Iface : Entity_Id); -- Add the interface it if is not already in the list - procedure Collect (Typ : Entity_Id); + procedure Collect (Typ : Entity_Id); -- Subsidiary subprogram used to traverse the whole list -- of directly and indirectly implemented interfaces @@ -453,34 +463,34 @@ package body Exp_Disp is ------------- procedure Collect (Typ : Entity_Id) is - Nod : constant Node_Id := Type_Definition (Parent (Typ)); + Ancestor : Entity_Id; Id : Node_Id; Iface : Entity_Id; - Ancestor : Entity_Id; + Nod : Node_Id; begin + if Ekind (Typ) = E_Record_Type_With_Private then + Nod := Type_Definition (Parent (Full_View (Typ))); + else + Nod := Type_Definition (Parent (Typ)); + end if; + pragma Assert (False or else Nkind (Nod) = N_Derived_Type_Definition or else Nkind (Nod) = N_Record_Definition); - if Nkind (Nod) = N_Record_Definition then - return; - end if; - -- Include the ancestor if we are generating the whole list -- of interfaces. This is used to know the size of the table -- that stores the tag of all the ancestor interfaces. Ancestor := Etype (Typ); - if Is_Interface (Ancestor) then - Add_Interface (Ancestor); + if Ancestor /= Typ then + Collect (Ancestor); end if; - if Ancestor /= Typ - and then Ekind (Ancestor) /= E_Record_Type_With_Private - then - Collect (Ancestor); + if Is_Interface (Ancestor) then + Add_Interface (Ancestor); end if; -- Traverse the graph of ancestor interfaces @@ -1008,7 +1018,10 @@ package body Exp_Disp is -- Expand_Interface_Conversion -- --------------------------------- - procedure Expand_Interface_Conversion (N : Node_Id) is + procedure Expand_Interface_Conversion + (N : Node_Id; + Is_Static : Boolean := True) + is Loc : constant Source_Ptr := Sloc (N); Operand : constant Node_Id := Expression (N); Operand_Typ : Entity_Id := Etype (Operand); @@ -1046,6 +1059,40 @@ package body Exp_Disp is pragma Assert (not Is_Class_Wide_Type (Iface_Typ) and then Is_Interface (Iface_Typ)); + if not Is_Static then + Rewrite (N, + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Displace), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => Relocate_Node (Expression (N)), + Attribute_Name => Name_Address), + New_Occurrence_Of + (Node (First_Elmt (Access_Disp_Table (Iface_Typ))), + Loc)))); + + Analyze (N); + + -- Change the type of the data returned by IW_Convert to + -- indicate that this is a dispatching call. + + declare + New_Itype : Entity_Id; + + begin + New_Itype := Create_Itype (E_Anonymous_Access_Type, N); + Set_Etype (New_Itype, New_Itype); + Init_Size_Align (New_Itype); + Set_Directly_Designated_Type (New_Itype, + Class_Wide_Type (Iface_Typ)); + + Rewrite (N, Unchecked_Convert_To (New_Itype, + Relocate_Node (N))); + end; + + return; + end if; + Iface_Tag := Find_Interface_Tag (Operand_Typ, Iface_Typ); pragma Assert (Iface_Tag /= Empty); @@ -1359,8 +1406,7 @@ package body Exp_Disp is function Expand_Interface_Thunk (N : Node_Id; Thunk_Alias : Entity_Id; - Thunk_Id : Entity_Id; - Thunk_Tag : Entity_Id) return Node_Id + Thunk_Id : Entity_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (N); Actuals : constant List_Id := New_List; @@ -1417,7 +1463,7 @@ package body Exp_Disp is -- type T is access all <<type of the first formal>> -- S1 := Storage_Offset!(First_formal) - -- - Storage_Offset!(First_Formal.Thunk_Tag'Position) + -- - Offset_To_Top (First_Formal.Tag) -- ... and the first actual of the call is generated as T!(S1) @@ -1452,17 +1498,15 @@ package body Exp_Disp is New_Reference_To (Defining_Identifier (First (Formals)), Loc)), Right_Opnd => - Unchecked_Convert_To - (RTE (RE_Storage_Offset), - Make_Attribute_Reference (Loc, - Prefix => - Make_Selected_Component (Loc, - Prefix => - New_Reference_To - (Defining_Identifier (First (Formals)), Loc), - Selector_Name => - New_Occurrence_Of (Thunk_Tag, Loc)), - Attribute_Name => Name_Position)))); + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Offset_To_Top), Loc), + Parameter_Associations => New_List ( + Make_Selected_Component (Loc, + Prefix => New_Reference_To + (Defining_Identifier (First (Formals)), + Loc), + Selector_Name => Make_Identifier (Loc, + Name_uTag)))))); Append_To (Decl, Decl_2); Append_To (Decl, Decl_1); @@ -1474,14 +1518,11 @@ package body Exp_Disp is (Defining_Identifier (Decl_2), New_Reference_To (Defining_Identifier (Decl_1), Loc))); - -- Side note: The reverse order of declarations is just to ensure - -- that the call to RE_Print is correct. - else -- Generate: - -- + -- S1 := Storage_Offset!(First_formal'Address) - -- - Storage_Offset!(First_Formal.Thunk_Tag'Position) + -- - Offset_To_Top (First_Formal.Tag) -- S2 := Tag_Ptr!(S3) Decl_1 := @@ -1502,17 +1543,15 @@ package body Exp_Disp is (Defining_Identifier (First (Formals)), Loc), Attribute_Name => Name_Address)), Right_Opnd => - Unchecked_Convert_To - (RTE (RE_Storage_Offset), - Make_Attribute_Reference (Loc, - Prefix => - Make_Selected_Component (Loc, - Prefix => - New_Reference_To - (Defining_Identifier (First (Formals)), Loc), - Selector_Name => - New_Occurrence_Of (Thunk_Tag, Loc)), - Attribute_Name => Name_Position)))); + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Offset_To_Top), Loc), + Parameter_Associations => New_List ( + Make_Selected_Component (Loc, + Prefix => New_Reference_To + (Defining_Identifier (First (Formals)), + Loc), + Selector_Name => Make_Identifier (Loc, + Name_uTag)))))); Decl_2 := Make_Object_Declaration (Loc, @@ -1726,6 +1765,8 @@ package body Exp_Disp is Stmts : constant List_Id := New_List; begin + -- Null body is generated for interface types + if Is_Interface (Typ) then return Make_Subprogram_Body (Loc, @@ -1738,16 +1779,13 @@ package body Exp_Disp is New_List (Make_Null_Statement (Loc)))); end if; - if Is_Concurrent_Record_Type (Typ) then - Conc_Typ := Corresponding_Concurrent_Type (Typ); - end if; - DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); - if Present (Conc_Typ) then + if Is_Concurrent_Record_Type (Typ) then + Conc_Typ := Corresponding_Concurrent_Type (Typ); -- Generate: - -- I : Integer := get_entry_index (tag! (<type>VP), S); + -- 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. @@ -1847,12 +1885,6 @@ package body Exp_Disp is RTE (RE_Asynchronous_Call), Loc), Make_Identifier (Loc, Name_uF)))); -- status flag end if; - - -- Implementation for limited tagged types - - else - Append_To (Stmts, - Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise)); end if; return @@ -1914,6 +1946,8 @@ package body Exp_Disp is Stmts : constant List_Id := New_List; begin + -- Null body is generated for interface types + if Is_Interface (Typ) then return Make_Subprogram_Body (Loc, @@ -1926,13 +1960,10 @@ package body Exp_Disp is New_List (Make_Null_Statement (Loc)))); end if; - if Is_Concurrent_Record_Type (Typ) then - Conc_Typ := Corresponding_Concurrent_Type (Typ); - end if; - DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); - if Present (Conc_Typ) then + if Is_Concurrent_Record_Type (Typ) then + Conc_Typ := Corresponding_Concurrent_Type (Typ); -- Generate: -- I : Integer; @@ -1946,22 +1977,20 @@ package body Exp_Disp is 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; + -- Generate: + -- C := Get_Prim_Op_Kind (tag! (<type>VP), S); - SEU.Build_Common_Dispatching_Select_Statements (Loc, Typ, DT_Ptr, Stmts); + -- if C = POK_Procedure + -- or else C = POK_Protected_Procedure + -- or else C = POK_Task_Procedure; + -- then + -- F := True; + -- return; + -- end if; - if Present (Conc_Typ) then + SEU.Build_Common_Dispatching_Select_Statements + (Loc, Typ, DT_Ptr, Stmts); -- Generate: -- Bnn : Communication_Block; @@ -1979,7 +2008,7 @@ package body Exp_Disp is New_Reference_To (RTE (RE_Communication_Block), Loc))); -- Generate: - -- I := get_entry_index (tag! (<type>VP), S); + -- I := Get_Entry_Index (tag! (<type>VP), S); -- I is the entry index and S is the dispatch table slot @@ -2097,12 +2126,6 @@ package body Exp_Disp is RTE (RE_Conditional_Call), Loc), Make_Identifier (Loc, Name_uF)))); -- status flag end if; - - -- Implementation for limited tagged types - - else - Append_To (Stmts, - Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise)); end if; return @@ -2318,6 +2341,8 @@ package body Exp_Disp is Stmts : constant List_Id := New_List; begin + -- Null body is generated for interface types + if Is_Interface (Typ) then return Make_Subprogram_Body (Loc, @@ -2330,13 +2355,10 @@ package body Exp_Disp is New_List (Make_Null_Statement (Loc)))); end if; - if Is_Concurrent_Record_Type (Typ) then - Conc_Typ := Corresponding_Concurrent_Type (Typ); - end if; - DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); - if Present (Conc_Typ) then + if Is_Concurrent_Record_Type (Typ) then + Conc_Typ := Corresponding_Concurrent_Type (Typ); -- Generate: -- I : Integer; @@ -2350,25 +2372,23 @@ package body Exp_Disp is 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; + -- Generate: + -- C := Get_Prim_Op_Kind (tag! (<type>VP), S); - SEU.Build_Common_Dispatching_Select_Statements (Loc, Typ, DT_Ptr, Stmts); + -- if C = POK_Procedure + -- or else C = POK_Protected_Procedure + -- or else C = POK_Task_Procedure; + -- then + -- F := True; + -- return; + -- end if; - if Present (Conc_Typ) then + SEU.Build_Common_Dispatching_Select_Statements + (Loc, Typ, DT_Ptr, Stmts); -- Generate: - -- I := get_entry_index (tag! (<type>VP), S); + -- I := Get_Entry_Index (tag! (<type>VP), S); -- I is the entry index and S is the dispatch table slot @@ -2469,12 +2489,6 @@ package body Exp_Disp is Make_Identifier (Loc, Name_uM), -- delay mode Make_Identifier (Loc, Name_uF)))); -- status flag end if; - - -- Implementation for limited tagged types - - else - Append_To (Stmts, - Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise)); end if; return @@ -2554,6 +2568,7 @@ package body Exp_Disp is Name_TSD : constant Name_Id := New_External_Name (Tname, 'B'); Name_Exname : constant Name_Id := New_External_Name (Tname, 'E'); Name_No_Reg : constant Name_Id := New_External_Name (Tname, 'F'); + Name_ITable : Name_Id; DT : constant Node_Id := Make_Defining_Identifier (Loc, Name_DT); DT_Ptr : constant Node_Id := Make_Defining_Identifier (Loc, Name_DT_Ptr); @@ -2561,17 +2576,21 @@ package body Exp_Disp is TSD : constant Node_Id := Make_Defining_Identifier (Loc, Name_TSD); Exname : constant Node_Id := Make_Defining_Identifier (Loc, Name_Exname); No_Reg : constant Node_Id := Make_Defining_Identifier (Loc, Name_No_Reg); - - Generalized_Tag : constant Entity_Id := RTE (RE_Tag); - I_Depth : Int; - Size_Expr_Node : Node_Id; - Old_Tag1 : Node_Id; - Old_Tag2 : Node_Id; - Num_Ifaces : Int; - Nb_Prim : Int; - TSD_Num_Entries : Int; - Typ_Copy : constant Entity_Id := New_Copy (Typ); - AI : Elmt_Id; + ITable : Node_Id; + + Generalized_Tag : constant Entity_Id := RTE (RE_Tag); + AI : Elmt_Id; + I_Depth : Int; + Nb_Prim : Int; + Num_Ifaces : Int; + Old_Tag1 : Node_Id; + Old_Tag2 : Node_Id; + Parent_Num_Ifaces : Int; + Size_Expr_Node : Node_Id; + TSD_Num_Entries : Int; + + Ancestor_Copy : Entity_Id; + Typ_Copy : Entity_Id; begin if not RTE_Available (RE_Tag) then @@ -2579,27 +2598,44 @@ package body Exp_Disp is return New_List; end if; - -- Collect full list of directly and indirectly implemented interfaces - - Set_Parent (Typ_Copy, Parent (Typ)); - Set_Abstract_Interfaces (Typ_Copy, New_Elmt_List); - Collect_All_Interfaces (Typ_Copy); - -- Calculate the size of the DT and the TSD if Is_Interface (Typ) then -- Abstract interfaces need neither the DT nor the ancestors table. -- We reserve a single entry for its DT because at run-time the - -- pointer to this dummy DT is the tag of this abstract interface - -- type. + -- pointer to this dummy DT will be used as the tag of this abstract + -- interface type. Nb_Prim := 1; TSD_Num_Entries := 0; + Num_Ifaces := 0; else - -- Calculate the number of entries for the table of interfaces + -- Count the number of interfaces implemented by the ancestors + + Parent_Num_Ifaces := 0; + Num_Ifaces := 0; + + if Typ /= Etype (Typ) then + Ancestor_Copy := New_Copy (Etype (Typ)); + Set_Parent (Ancestor_Copy, Parent (Etype (Typ))); + Set_Abstract_Interfaces (Ancestor_Copy, New_Elmt_List); + Collect_All_Interfaces (Ancestor_Copy); + + AI := First_Elmt (Abstract_Interfaces (Ancestor_Copy)); + while Present (AI) loop + Parent_Num_Ifaces := Parent_Num_Ifaces + 1; + Next_Elmt (AI); + end loop; + end if; + + -- Count the number of additional interfaces implemented by Typ + + Typ_Copy := New_Copy (Typ); + Set_Parent (Typ_Copy, Parent (Typ)); + Set_Abstract_Interfaces (Typ_Copy, New_Elmt_List); + Collect_All_Interfaces (Typ_Copy); - Num_Ifaces := 0; AI := First_Elmt (Abstract_Interfaces (Typ_Copy)); while Present (AI) loop Num_Ifaces := Num_Ifaces + 1; @@ -2630,7 +2666,7 @@ package body Exp_Disp is end loop; end; - TSD_Num_Entries := I_Depth + Num_Ifaces + 1; + TSD_Num_Entries := I_Depth + 1; Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ))); -- If the number of primitives of Typ is less that the number of @@ -2650,6 +2686,16 @@ package body Exp_Disp is Set_Ekind (DT_Ptr, E_Variable); Set_Is_Statically_Allocated (DT_Ptr); + if not Is_Interface (Typ) + and then Num_Ifaces > 0 + then + Name_ITable := New_External_Name (Tname, 'I'); + ITable := Make_Defining_Identifier (Loc, Name_ITable); + + Set_Ekind (ITable, E_Variable); + Set_Is_Statically_Allocated (ITable); + end if; + Set_Ekind (SSD, E_Variable); Set_Is_Statically_Allocated (SSD); @@ -2842,6 +2888,47 @@ package body Exp_Disp is Prefix => New_Reference_To (TSD, Loc), Attribute_Name => Name_Address)))); + -- Set the pointer to the Interfaces_Table (if any). Otherwise the + -- corresponding access component is set to null. + + if Is_Interface (Typ) then + null; + + elsif Num_Ifaces = 0 then + Append_To (Elab_Code, + Make_DT_Access_Action (Typ, + Action => Set_Interface_Table, + Args => New_List ( + New_Reference_To (DT_Ptr, Loc), -- DTptr + New_Reference_To (RTE (RE_Null_Address), Loc)))); -- null + + -- Generate the Interface_Table object and set the access + -- component if the TSD to it. + + else + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => ITable, + Aliased_Present => True, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Reference_To + (RTE (RE_Interface_Data), Loc), + Constraint => Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + Make_Integer_Literal (Loc, + Num_Ifaces)))))); + + Append_To (Elab_Code, + Make_DT_Access_Action (Typ, + Action => Set_Interface_Table, + Args => New_List ( + New_Reference_To (DT_Ptr, Loc), -- DTptr + Make_Attribute_Reference (Loc, -- Value + Prefix => New_Reference_To (ITable, Loc), + Attribute_Name => Name_Address)))); + end if; + -- Generate: -- Set_Num_Prim_Ops (T'Tag, Nb_Prim) @@ -2858,39 +2945,53 @@ package body Exp_Disp is and then not Is_Interface (Typ) and then not Is_Abstract (Typ) and then not Is_Controlled (Typ) - and then Implements_Interface ( - Typ => Typ, - Kind => Any_Limited_Interface, - Check_Parent => True) - and then (Nb_Prim - Default_Prim_Op_Count) > 0 then - -- Generate the Select Specific Data table for tagged types that - -- implement a synchronized interface. The size of the table is - -- constrained by the number of non-predefined primitive operations. - - Append_To (Result, - Make_Object_Declaration (Loc, - Defining_Identifier => SSD, - Aliased_Present => True, - Object_Definition => - Make_Subtype_Indication (Loc, - Subtype_Mark => New_Reference_To ( - RTE (RE_Select_Specific_Data), Loc), - Constraint => Make_Index_Or_Discriminant_Constraint (Loc, - Constraints => New_List ( - Make_Integer_Literal (Loc, - Nb_Prim - Default_Prim_Op_Count)))))); - - -- Set the pointer to the Select Specific Data table in the TSD + -- Generate: + -- Set_Type_Kind (T'Tag, Type_Kind (Typ)); Append_To (Elab_Code, Make_DT_Access_Action (Typ, - Action => Set_SSD, + Action => Set_Tagged_Kind, Args => New_List ( New_Reference_To (DT_Ptr, Loc), -- DTptr - Make_Attribute_Reference (Loc, -- Value - Prefix => New_Reference_To (SSD, Loc), - Attribute_Name => Name_Address)))); + Tagged_Kind (Typ)))); -- Value + + -- Generate the Select Specific Data table for synchronized + -- types that implement a synchronized interface. The size + -- of the table is constrained by the number of non-predefined + -- primitive operations. + + if Is_Concurrent_Record_Type (Typ) + and then Implements_Interface ( + Typ => Typ, + Kind => Any_Limited_Interface, + Check_Parent => True) + and then (Nb_Prim - Default_Prim_Op_Count) > 0 + then + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => SSD, + Aliased_Present => True, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Reference_To ( + RTE (RE_Select_Specific_Data), Loc), + Constraint => Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + Make_Integer_Literal (Loc, + Nb_Prim - Default_Prim_Op_Count)))))); + + -- Set the pointer to the Select Specific Data table in the TSD + + Append_To (Elab_Code, + Make_DT_Access_Action (Typ, + Action => Set_SSD, + Args => New_List ( + New_Reference_To (DT_Ptr, Loc), -- DTptr + Make_Attribute_Reference (Loc, -- Value + Prefix => New_Reference_To (SSD, Loc), + Attribute_Name => Name_Address)))); + end if; end if; -- Generate: Exname : constant String := full_qualified_name (typ); @@ -3158,12 +3259,13 @@ package body Exp_Disp is end; -- Generate: - -- Set_Offset_To_Top (DT_Ptr, 0); + -- Set_Offset_To_Top (0, DT_Ptr, 0); Append_To (Elab_Code, Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (RTE (RE_Set_Offset_To_Top), Loc), Parameter_Associations => New_List ( + New_Reference_To (RTE (RE_Null_Address), Loc), New_Reference_To (DT_Ptr, Loc), Make_Integer_Literal (Loc, Uint_0)))); end if; @@ -3222,31 +3324,82 @@ package body Exp_Disp is Then_Statements => Elab_Code)); -- Ada 2005 (AI-251): Register the tag of the interfaces into - -- the table of implemented interfaces and ... + -- the table of implemented interfaces. if not Is_Interface (Typ) - and then Present (Abstract_Interfaces (Typ_Copy)) - and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ_Copy)) + and then Num_Ifaces > 0 then - AI := First_Elmt (Abstract_Interfaces (Typ_Copy)); - while Present (AI) loop + declare + Position : Int; - -- Generate: - -- Register_Interface (DT_Ptr, Interface'Tag); + begin + -- If the parent is an interface we must generate code to register + -- all its interfaces; otherwise this code is not needed because + -- Inherit_TSD has already inherited such interfaces. - Append_To (Result, - Make_DT_Access_Action (Typ, - Action => Register_Interface_Tag, - Args => New_List ( - Node1 => New_Reference_To (DT_Ptr, Loc), - Node2 => New_Reference_To - (Node - (First_Elmt - (Access_Disp_Table (Node (AI)))), - Loc)))); + if Is_Interface (Etype (Typ)) then + Position := 1; - Next_Elmt (AI); - end loop; + AI := First_Elmt (Abstract_Interfaces (Ancestor_Copy)); + while Present (AI) loop + -- Generate: + -- Register_Interface (DT_Ptr, Interface'Tag); + + Append_To (Result, + Make_DT_Access_Action (Typ, + Action => Register_Interface_Tag, + Args => New_List ( + Node1 => New_Reference_To (DT_Ptr, Loc), + Node2 => New_Reference_To + (Node + (First_Elmt + (Access_Disp_Table (Node (AI)))), + Loc), + Node3 => Make_Integer_Literal (Loc, Position)))); + + Position := Position + 1; + Next_Elmt (AI); + end loop; + end if; + + -- Register the interfaces that are not implemented by the + -- ancestor + + if Present (Abstract_Interfaces (Typ_Copy)) then + AI := First_Elmt (Abstract_Interfaces (Typ_Copy)); + + -- Skip the interfaces implemented by the ancestor + + for Count in 1 .. Parent_Num_Ifaces loop + Next_Elmt (AI); + end loop; + + -- Register the additional interfaces + + Position := Parent_Num_Ifaces + 1; + while Present (AI) loop + -- Generate: + -- Register_Interface (DT_Ptr, Interface'Tag); + + Append_To (Result, + Make_DT_Access_Action (Typ, + Action => Register_Interface_Tag, + Args => New_List ( + Node1 => New_Reference_To (DT_Ptr, Loc), + Node2 => New_Reference_To + (Node + (First_Elmt + (Access_Disp_Table (Node (AI)))), + Loc), + Node3 => Make_Integer_Literal (Loc, Position)))); + + Position := Position + 1; + Next_Elmt (AI); + end loop; + end if; + + pragma Assert (Position = Num_Ifaces + 1); + end; end if; return Result; @@ -3471,7 +3624,7 @@ package body Exp_Disp is Make_Index_Or_Discriminant_Constraint (Loc, Constraints => New_List ( Make_Integer_Literal (Loc, - Nb_Prim - Default_Prim_Op_Count)))))); + Nb_Prim - Default_Prim_Op_Count + 1)))))); -- Generate: -- Ada.Tags.Set_OSD (Iface_DT_Ptr, OSD); @@ -3480,63 +3633,12 @@ package body Exp_Disp is Make_DT_Access_Action (Typ, Action => Set_OSD, Args => New_List ( - New_Reference_To (Iface_DT_Ptr, Loc), + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (Iface_DT_Ptr, Loc)), Make_Attribute_Reference (Loc, Prefix => New_Reference_To (OSD, Loc), Attribute_Name => Name_Address)))); - -- Offset table creation - - if not Is_Interface (Typ) - and then not Is_Abstract (Typ) - and then not Is_Controlled (Typ) - and then Implements_Interface - (Typ => Typ, - Kind => Any_Limited_Interface, - Check_Parent => True) - and then (Nb_Prim - Default_Prim_Op_Count) > 0 - then - declare - Prim : Entity_Id; - Prim_Alias : Entity_Id; - Prim_Elmt : Elmt_Id; - - begin - -- Step 2: Populate the OSD table - - Prim_Alias := Empty; - Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); - while Present (Prim_Elmt) loop - Prim := Node (Prim_Elmt); - - if Present (Abstract_Interface_Alias (Prim)) then - Prim_Alias := Abstract_Interface_Alias (Prim); - end if; - - if Present (Prim_Alias) - and then Present (First_Entity (Prim_Alias)) - and then Etype (First_Entity (Prim_Alias)) = Iface - then - -- Generate: - -- Ada.Tags.Set_Offset_Index ( - -- Iface_DT_Ptr, secondary_DT_Pos, primary_DT_pos); - - Append_To (Result, - Make_DT_Access_Action (Iface, - Action => Set_Offset_Index, - Args => New_List ( - New_Reference_To (Iface_DT_Ptr, Loc), - Make_Integer_Literal (Loc, DT_Position (Prim_Alias)), - Make_Integer_Literal (Loc, DT_Position (Prim))))); - - Prim_Alias := Empty; - end if; - - Next_Elmt (Prim_Elmt); - end loop; - end; - end if; - -- Generate: -- Set_Num_Prim_Ops (T'Tag, Nb_Prim) @@ -3548,6 +3650,73 @@ package body Exp_Disp is New_Reference_To (Iface_DT_Ptr, Loc)), Make_Integer_Literal (Loc, Nb_Prim)))); + if Ada_Version >= Ada_05 + and then not Is_Interface (Typ) + and then not Is_Abstract (Typ) + and then not Is_Controlled (Typ) + then + -- Generate: + -- Set_Tagged_Kind (Iface'Tag, Tagged_Kind (Iface)); + + Append_To (Result, + Make_DT_Access_Action (Typ, + Action => Set_Tagged_Kind, + Args => New_List ( + Unchecked_Convert_To (RTE (RE_Tag), -- DTptr + New_Reference_To (Iface_DT_Ptr, Loc)), + Tagged_Kind (Typ)))); -- Value + + if Is_Concurrent_Record_Type (Typ) + and then Implements_Interface ( + Typ => Typ, + Kind => Any_Limited_Interface, + Check_Parent => True) + and then (Nb_Prim - Default_Prim_Op_Count) > 0 + then + declare + Prim : Entity_Id; + Prim_Alias : Entity_Id; + Prim_Elmt : Elmt_Id; + + begin + -- Step 2: Populate the OSD table + + Prim_Alias := Empty; + Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + + if Present (Abstract_Interface_Alias (Prim)) then + Prim_Alias := Abstract_Interface_Alias (Prim); + end if; + + if Present (Prim_Alias) + and then Present (First_Entity (Prim_Alias)) + and then Etype (First_Entity (Prim_Alias)) = Iface + then + -- Generate: + -- Ada.Tags.Set_Offset_Index (Tag (Iface_DT_Ptr), + -- Secondary_DT_Pos, Primary_DT_pos); + + Append_To (Result, + Make_DT_Access_Action (Iface, + Action => Set_Offset_Index, + Args => New_List ( + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (Iface_DT_Ptr, Loc)), + Make_Integer_Literal (Loc, + DT_Position (Prim_Alias)), + Make_Integer_Literal (Loc, + DT_Position (Prim))))); + + Prim_Alias := Empty; + end if; + + Next_Elmt (Prim_Elmt); + end loop; + end; + end if; + end if; end Make_Secondary_DT; ------------------------------------- @@ -4413,6 +4582,49 @@ package body Exp_Disp is end if; end Set_Default_Constructor; + ----------------- + -- Tagged_Kind -- + ----------------- + + function Tagged_Kind (T : Entity_Id) return Node_Id is + Conc_Typ : Entity_Id; + Loc : constant Source_Ptr := Sloc (T); + + begin + pragma Assert (Is_Tagged_Type (T)); + + -- Abstract kinds + + if Is_Abstract (T) then + if Is_Limited_Record (T) then + return New_Reference_To (RTE (RE_TK_Abstract_Limited_Tagged), Loc); + else + return New_Reference_To (RTE (RE_TK_Abstract_Tagged), Loc); + end if; + + -- Concurrent kinds + + elsif Is_Concurrent_Record_Type (T) then + Conc_Typ := Corresponding_Concurrent_Type (T); + + if Ekind (Conc_Typ) = E_Protected_Type then + return New_Reference_To (RTE (RE_TK_Protected), Loc); + else + pragma Assert (Ekind (Conc_Typ) = E_Task_Type); + return New_Reference_To (RTE (RE_TK_Task), Loc); + end if; + + -- Regular tagged kinds + + else + if Is_Limited_Record (T) then + return New_Reference_To (RTE (RE_TK_Limited_Tagged), Loc); + else + return New_Reference_To (RTE (RE_TK_Tagged), Loc); + end if; + end if; + end Tagged_Kind; + -------------- -- Write_DT -- -------------- diff --git a/gcc/ada/exp_disp.ads b/gcc/ada/exp_disp.ads index bdc1417d4c4..a0f6b18672d 100644 --- a/gcc/ada/exp_disp.ads +++ b/gcc/ada/exp_disp.ads @@ -184,11 +184,11 @@ package Exp_Disp is Get_Access_Level, Get_Entry_Index, Get_External_Tag, - Get_Offset_Index, Get_Prim_Op_Address, Get_Prim_Op_Kind, Get_RC_Offset, Get_Remotely_Callable, + Get_Tagged_Kind, Inherit_DT, Inherit_TSD, Register_Interface_Tag, @@ -197,6 +197,7 @@ package Exp_Disp is Set_Entry_Index, Set_Expanded_Name, Set_External_Tag, + Set_Interface_Table, Set_Offset_Index, Set_OSD, Set_Prim_Op_Address, @@ -205,6 +206,7 @@ package Exp_Disp is Set_Remotely_Callable, Set_SSD, Set_TSD, + Set_Tagged_Kind, TSD_Entry_Size, TSD_Prologue_Size); @@ -217,16 +219,17 @@ package Exp_Disp is -- 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); + procedure Expand_Interface_Conversion + (N : Node_Id; + Is_Static : Boolean := True); -- 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 + -- 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; + Thunk_Id : 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 diff --git a/gcc/ada/exp_sel.adb b/gcc/ada/exp_sel.adb new file mode 100644 index 00000000000..dbb7fb29086 --- /dev/null +++ b/gcc/ada/exp_sel.adb @@ -0,0 +1,220 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ S E L -- +-- -- +-- B o d y -- +-- -- +-- 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- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Einfo; use Einfo; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Rtsfind; use Rtsfind; +with Stand; use Stand; +with Tbuild; use Tbuild; + +package body Exp_Sel is + + ----------------------- + -- Build_Abort_Block -- + ----------------------- + + function Build_Abort_Block + (Loc : Source_Ptr; + Abr_Blk_Ent : Entity_Id; + Cln_Blk_Ent : Entity_Id; + Blk : Node_Id) return Node_Id + is + begin + return + Make_Block_Statement (Loc, + Identifier => New_Reference_To (Abr_Blk_Ent, Loc), + + Declarations => No_List, + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => + New_List ( + Make_Implicit_Label_Declaration (Loc, + Defining_Identifier => + Cln_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, + Chars => New_Internal_Name ('B')); + + 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, + Chars => New_Internal_Name ('C')); + + 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_K -- + ------------- + + function Build_K + (Loc : Source_Ptr; + Decls : List_Id; + Obj : Entity_Id) return Entity_Id + is + K : constant Entity_Id := Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('K')); + + begin + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => K, + Object_Definition => + New_Reference_To (RTE (RE_Tagged_Kind), Loc), + Expression => + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Get_Tagged_Kind), Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_Tag), Obj))))); + + return K; + end Build_K; + + ------------- + -- Build_S -- + ------------- + + function Build_S + (Loc : Source_Ptr; + Decls : List_Id) return Entity_Id + is + S : constant Entity_Id := Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('S')); + + begin + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => S, + Object_Definition => + New_Reference_To (Standard_Integer, Loc))); + + return S; + end Build_S; + + ------------------------ + -- Build_S_Assignment -- + ------------------------ + + function Build_S_Assignment + (Loc : Source_Ptr; + S : Entity_Id; + Obj : Entity_Id; + Call_Ent : Entity_Id) return Node_Id + is + begin + return + Make_Assignment_Statement (Loc, + Name => New_Reference_To (S, Loc), + Expression => + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Get_Offset_Index), Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_Tag), Obj), + Make_Integer_Literal (Loc, DT_Position (Call_Ent))))); + end Build_S_Assignment; + +end Exp_Sel; diff --git a/gcc/ada/exp_sel.ads b/gcc/ada/exp_sel.ads new file mode 100644 index 00000000000..fd8caceeee6 --- /dev/null +++ b/gcc/ada/exp_sel.ads @@ -0,0 +1,113 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ S E L -- +-- -- +-- S p e c -- +-- -- +-- 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- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Routines used in Chapter 9 for the expansion of dispatching triggers in +-- select statements (Ada 2005: AI-345) + +with Types; use Types; + +package Exp_Sel is + + function Build_Abort_Block + (Loc : Source_Ptr; + Abr_Blk_Ent : Entity_Id; + Cln_Blk_Ent : Entity_Id; + Blk : Node_Id) return Node_Id; + -- Generate: + -- begin + -- Blk + -- exception + -- when Abort_Signal => Abort_Undefer; + -- end; + -- Abr_Blk_Ent is the name of the generated block, Cln_Blk_Ent is the name + -- of the encapsulated cleanup block, Blk is the actual block name. + + 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 its defining + -- identifier. + + 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 its defining + -- identifier. + + 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_K + (Loc : Source_Ptr; + Decls : List_Id; + Obj : Entity_Id) return Entity_Id; + -- Generate + -- K : Ada.Tags.Tagged_Kind := + -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (Obj)); + -- where Obj is the pointer to a secondary table. Append the object + -- declaration to the list and return its defining identifier. + + function Build_S + (Loc : Source_Ptr; + Decls : List_Id) return Entity_Id; + -- Generate: + -- S : Integer; + -- Append the object declaration to the list and return its defining + -- identifier. + + function Build_S_Assignment + (Loc : Source_Ptr; + S : Entity_Id; + Obj : Entity_Id; + Call_Ent : Entity_Id) return Node_Id; + -- Generate: + -- S := Ada.Tags.Get_Offset_Index ( + -- Ada.Tags.Tag (Obj), DT_Position (Call_Ent)); + -- where Obj is the pointer to a secondary table, Call_Ent is the entity + -- of the dispatching call name. Return the generated assignment. + +end Exp_Sel; diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 8b19055fef9..3b4522c85f9 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -120,6 +120,7 @@ package Rtsfind is Ada_Streams, Ada_Tags, Ada_Task_Identification, + Ada_Task_Termination, -- Children of Ada.Calendar @@ -488,10 +489,12 @@ package Rtsfind is RE_Stream_Access, -- Ada.Streams.Stream_IO + RE_Abstract_Interface, -- Ada.Tags RE_Addr_Ptr, -- Ada.Tags + RE_Address_Array, -- Ada.Tags RE_CW_Membership, -- Ada.Tags - RE_IW_Membership, -- Ada.Tags RE_Descendant_Tag, -- Ada.Tags + RE_Displace, -- Ada.Tags RE_DT_Entry_Size, -- Ada.Tags RE_DT_Prologue_Size, -- Ada.Tags RE_External_Tag, -- Ada.Tags @@ -503,11 +506,16 @@ package Rtsfind is RE_Get_Prim_Op_Kind, -- Ada.Tags RE_Get_RC_Offset, -- Ada.Tags RE_Get_Remotely_Callable, -- Ada.Tags + RE_Get_Tagged_Kind, -- Ada.Tags RE_Inherit_DT, -- Ada.Tags RE_Inherit_TSD, -- Ada.Tags + RE_Interface_Data, -- Ada.Tags + RE_Interface_Tag, -- Ada.Tags RE_Internal_Tag, -- Ada.Tags RE_Is_Descendant_At_Same_Level, -- Ada.Tags + RE_IW_Membership, -- Ada.Tags RE_Object_Specific_Data, -- Ada.Tags + RE_Offset_To_Top, -- Ada.Tags RE_POK_Function, -- Ada.Tags RE_POK_Procedure, -- Ada.Tags RE_POK_Protected_Entry, -- Ada.Tags @@ -517,13 +525,16 @@ package Rtsfind is RE_POK_Task_Function, -- Ada.Tags RE_POK_Task_Procedure, -- Ada.Tags RE_Prim_Op_Kind, -- Ada.Tags + RE_Primary_DT, -- Ada.Tags RE_Register_Interface_Tag, -- Ada.Tags RE_Register_Tag, -- Ada.Tags + RE_Secondary_DT, -- Ada.Tags RE_Select_Specific_Data, -- 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_Interface_Table, -- Ada.Tags RE_Set_Num_Prim_Ops, -- Ada.Tags RE_Set_Offset_Index, -- Ada.Tags RE_Set_Offset_To_Top, -- Ada.Tags @@ -533,17 +544,20 @@ package Rtsfind is RE_Set_RC_Offset, -- Ada.Tags RE_Set_Remotely_Callable, -- Ada.Tags RE_Set_SSD, -- Ada.Tags + RE_Set_Tagged_Kind, -- Ada.Tags RE_Set_TSD, -- Ada.Tags + RE_Tag, -- Ada.Tags RE_Tag_Error, -- Ada.Tags + RE_Tagged_Kind, -- Ada.Tags RE_TSD_Entry_Size, -- Ada.Tags RE_TSD_Prologue_Size, -- Ada.Tags - RE_Interface_Tag, -- Ada.Tags - RE_Tag, -- Ada.Tags - RE_Address_Array, -- Ada.Tags + RE_TK_Abstract_Limited_Tagged, -- Ada.Tags + RE_TK_Abstract_Tagged, -- Ada.Tags + RE_TK_Limited_Tagged, -- Ada.Tags + RE_TK_Protected, -- Ada.Tags + RE_TK_Tagged, -- Ada.Tags + RE_TK_Task, -- Ada.Tags RE_Valid_Signature, -- Ada.Tags - RE_Primary_DT, -- Ada.Tags - RE_Secondary_DT, -- Ada.Tags - RE_Abstract_Interface, -- Ada.Tags RE_Abort_Task, -- Ada.Task_Identification RE_Current_Task, -- Ada.Task_Identification @@ -1629,10 +1643,12 @@ package Rtsfind is RE_Stream_Access => Ada_Streams_Stream_IO, + RE_Abstract_Interface => Ada_Tags, RE_Addr_Ptr => Ada_Tags, + RE_Address_Array => Ada_Tags, RE_CW_Membership => Ada_Tags, - RE_IW_Membership => Ada_Tags, RE_Descendant_Tag => Ada_Tags, + RE_Displace => Ada_Tags, RE_DT_Entry_Size => Ada_Tags, RE_DT_Prologue_Size => Ada_Tags, RE_External_Tag => Ada_Tags, @@ -1644,11 +1660,16 @@ package Rtsfind is RE_Get_Prim_Op_Kind => Ada_Tags, RE_Get_RC_Offset => Ada_Tags, RE_Get_Remotely_Callable => Ada_Tags, + RE_Get_Tagged_Kind => Ada_Tags, RE_Inherit_DT => Ada_Tags, RE_Inherit_TSD => Ada_Tags, + RE_Interface_Data => Ada_Tags, + RE_Interface_Tag => Ada_Tags, RE_Internal_Tag => Ada_Tags, RE_Is_Descendant_At_Same_Level => Ada_Tags, + RE_IW_Membership => Ada_Tags, RE_Object_Specific_Data => Ada_Tags, + RE_Offset_To_Top => Ada_Tags, RE_POK_Function => Ada_Tags, RE_POK_Procedure => Ada_Tags, RE_POK_Protected_Entry => Ada_Tags, @@ -1658,13 +1679,16 @@ package Rtsfind is RE_POK_Task_Function => Ada_Tags, RE_POK_Task_Procedure => Ada_Tags, RE_Prim_Op_Kind => Ada_Tags, + RE_Primary_DT => Ada_Tags, RE_Register_Interface_Tag => Ada_Tags, RE_Register_Tag => Ada_Tags, + RE_Secondary_DT => Ada_Tags, RE_Select_Specific_Data => 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_Interface_Table => Ada_Tags, RE_Set_Num_Prim_Ops => Ada_Tags, RE_Set_Offset_Index => Ada_Tags, RE_Set_Offset_To_Top => Ada_Tags, @@ -1674,17 +1698,20 @@ package Rtsfind is RE_Set_RC_Offset => Ada_Tags, RE_Set_Remotely_Callable => Ada_Tags, RE_Set_SSD => Ada_Tags, + RE_Set_Tagged_Kind => Ada_Tags, RE_Set_TSD => Ada_Tags, + RE_Tag => Ada_Tags, RE_Tag_Error => Ada_Tags, + RE_Tagged_Kind => Ada_Tags, RE_TSD_Entry_Size => Ada_Tags, RE_TSD_Prologue_Size => Ada_Tags, - RE_Interface_Tag => Ada_Tags, - RE_Tag => Ada_Tags, - RE_Address_Array => Ada_Tags, + RE_TK_Abstract_Limited_Tagged => Ada_Tags, + RE_TK_Abstract_Tagged => Ada_Tags, + RE_TK_Limited_Tagged => Ada_Tags, + RE_TK_Protected => Ada_Tags, + RE_TK_Tagged => Ada_Tags, + RE_TK_Task => Ada_Tags, RE_Valid_Signature => Ada_Tags, - RE_Primary_DT => Ada_Tags, - RE_Secondary_DT => Ada_Tags, - RE_Abstract_Interface => Ada_Tags, RE_Abort_Task => Ada_Task_Identification, RE_Current_Task => Ada_Task_Identification, |