-- 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
-- | 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;
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;
-- 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
-- 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;
-- 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.
---------------------
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;
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 --
-------------------
-- 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
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;
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;
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;
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;
----------------------
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;
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 --
----------------
-----------------
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));
(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;
-------------------
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;
------------
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;
-- 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;
------------------
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;
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 --
----------------------
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;
----------------------
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;
-----------------------
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;
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;
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 --
-------------
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;
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;
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;
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;
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
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
-- 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.
-- 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
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
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.
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.
-- 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.
-- 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.
-- 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 :=
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);
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);
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);
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);
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);
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))
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
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 =>
-- 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,
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));
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,
-- 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));
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);
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);
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,
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;
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
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 --
-----------------------
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
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);
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);
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);
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
-- 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
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;
Formals : List_Id;
Hdle : List_Id;
Index : Node_Id;
+ Lim_Typ_Stmts : List_Id;
N_Orig : Node_Id;
Obj : Entity_Id;
Param : Node_Id;
B : Entity_Id; -- Call status flag
Bnn : Entity_Id; -- Communication block
C : Entity_Id; -- Call kind
+ K : Entity_Id; -- Tagged kind
P : Entity_Id; -- Parameter block
S : Entity_Id; -- Primitive operation slot
T : Entity_Id; -- Additional status flag
-- 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;
-- 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
(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:
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
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,
New_Reference_To (
Find_Prim_Op (Etype (Etype (Obj)),
Name_uDisp_Asynchronous_Select),
- Loc),
+ Loc),
Parameter_Associations =>
New_List (
New_Copy_Tree (Obj),
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
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
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,
New_Reference_To (
Find_Prim_Op (Etype (Etype (Obj)),
Name_uDisp_Asynchronous_Select),
- Loc),
+ Loc),
Parameter_Associations =>
New_List (
New_Copy_Tree (Obj),
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
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
ProtP_Stmts := New_Copy_List_Tree (Tstats);
Prepend_To (ProtP_Stmts, New_Copy_Tree (Ecall));
+ -- Generate:
+ -- S := Ada.Tags.Get_Offset_Index (
+ -- Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
+
+ Conc_Typ_Stmts := New_List (
+ Build_S_Assignment (Loc, S, Obj, Call_Ent));
+
+ -- Generate:
+ -- _Disp_Get_Prim_Op_Kind (<object>, S, C);
+
+ Append_To (Conc_Typ_Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_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
-- ProtP_Stmts
-- end if;
- Append_To (Stmts,
+ Append_To (Conc_Typ_Stmts,
Make_If_Statement (Loc,
Condition =>
Make_Op_Eq (Loc,
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 =>
-- 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;
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
-- 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 (
-- explicit assignments to their corresponding actuals.
if Present (Unpack) then
- Append_To (Stmts,
+ Append_To (Conc_Typ_Stmts,
Make_If_Statement (Loc,
Condition =>
Right_Opnd =>
New_Reference_To (RTE (RE_POK_Task_Entry), Loc))),
- Then_Statements => Unpack));
+ Then_Statements =>
+ Unpack));
end if;
-- Generate:
-- or else C = POK_Protected_Procedure
-- or else C = POK_Task_Procedure
-- then
- -- <dispatching-procedure-call>
+ -- <dispatching-call>
-- end if;
-- <normal-statements>
-- else
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,
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);
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,
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,
-- 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;
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
-- Generate:
-- B : Boolean := False;
- B := SEU.Build_B (Loc, Decls);
+ B := Build_B (Loc, Decls);
else
-- Generate:
-- Generate:
-- C : Ada.Tags.Prim_Op_Kind;
- C := SEU.Build_C (Loc, Decls);
+ C := Build_C (Loc, Decls);
end if;
-- Duration and mode processing
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
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 (
-- explicit assignments to their corresponding actuals.
if Present (Unpack) then
- Append_To (Stmts,
+ Append_To (Conc_Typ_Stmts,
Make_If_Statement (Loc,
Condition =>
Right_Opnd =>
New_Reference_To (RTE (RE_POK_Task_Entry), Loc))),
- Then_Statements => Unpack));
+ Then_Statements =>
+ Unpack));
end if;
-- Generate:
-- 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);
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
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)
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,
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,
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,
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);
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,
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,
Set_Remotely_Callable => True,
Set_SSD => True,
Set_TSD => True,
+ Set_Tagged_Kind => True,
TSD_Entry_Size => False,
TSD_Prologue_Size => False);
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,
Set_Remotely_Callable => 2,
Set_SSD => 2,
Set_TSD => 2,
+ Set_Tagged_Kind => 2,
TSD_Entry_Size => 0,
TSD_Prologue_Size => 0);
(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 --
----------------------------
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
-------------
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
-- 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);
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);
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;
-- 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)
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);
(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 :=
(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,
Stmts : constant List_Id := New_List;
begin
+ -- Null body is generated for interface types
+
if Is_Interface (Typ) then
return
Make_Subprogram_Body (Loc,
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.
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
Stmts : constant List_Id := New_List;
begin
+ -- Null body is generated for interface types
+
if Is_Interface (Typ) then
return
Make_Subprogram_Body (Loc,
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;
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;
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
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
Stmts : constant List_Id := New_List;
begin
+ -- Null body is generated for interface types
+
if Is_Interface (Typ) then
return
Make_Subprogram_Body (Loc,
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;
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
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
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);
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
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;
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
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);
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)
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);
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;
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;
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);
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)
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;
-------------------------------------
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 --
--------------
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,
Set_Entry_Index,
Set_Expanded_Name,
Set_External_Tag,
+ Set_Interface_Table,
Set_Offset_Index,
Set_OSD,
Set_Prim_Op_Address,
Set_Remotely_Callable,
Set_SSD,
Set_TSD,
+ Set_Tagged_Kind,
TSD_Entry_Size,
TSD_Prologue_Size);
-- 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
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
Ada_Streams,
Ada_Tags,
Ada_Task_Identification,
+ Ada_Task_Termination,
-- Children of Ada.Calendar
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
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
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
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
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,
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,
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,
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,
projects / gcc.git / commitdiff