-- | tags |
-- +-------------------+
-- | table of |
--- | interface |
+-- : interface :
-- | tags |
-- +-------------------+
+-- | table of |
+-- : primitive op :
+-- | kinds |
+-- +-------------------+
+-- | table of |
+-- : entry :
+-- | indices |
+-- +-------------------+
subtype Cstring is String (Positive);
type Cstring_Ptr is access all Cstring;
+ -- We suppress index checks because the declared size in the record below
+ -- is a dummy size of one (see below).
+
type Tag_Table is array (Natural range <>) of Tag;
pragma Suppress_Initialization (Tag_Table);
pragma Suppress (Index_Check, On => Tag_Table);
- -- We suppress index checks because the declared size in the record below
- -- is a dummy size of one (see below).
+
+ type Prim_Op_Kind_Table is array (Natural range <>) of Prim_Op_Kind;
+ pragma Suppress_Initialization (Prim_Op_Kind_Table);
+ pragma Suppress (Index_Check, On => Prim_Op_Kind_Table);
+
+ type Entry_Index_Table is array (Natural range <>) of Positive;
+ pragma Suppress_Initialization (Entry_Index_Table);
+ pragma Suppress (Index_Check, On => Entry_Index_Table);
type Type_Specific_Data is record
- Idepth : Natural;
+ Idepth : Natural;
-- Inheritance Depth Level: Used to implement the membership test
-- associated with single inheritance of tagged types in constant-time.
-- In addition it also indicates the size of the first table stored in
-- the Tags_Table component (see comment below).
- Access_Level : Natural;
+ Access_Level : Natural;
-- Accessibility level required to give support to Ada 2005 nested type
-- extensions. This feature allows safe nested type extensions by
-- shifting the accessibility checks to certain operations, rather than
-- function return, and class-wide stream I/O, the danger of objects
-- outliving their type declaration can be eliminated (Ada 2005: AI-344)
- Expanded_Name : Cstring_Ptr;
- External_Tag : Cstring_Ptr;
- HT_Link : Tag;
+ Expanded_Name : Cstring_Ptr;
+ External_Tag : Cstring_Ptr;
+ HT_Link : Tag;
-- Components used to give support to the Ada.Tags subprograms described
-- in ARM 3.9
Remotely_Callable : Boolean;
-- Used to check ARM E.4 (18)
- RC_Offset : SSE.Storage_Offset;
+ RC_Offset : SSE.Storage_Offset;
-- Controller Offset: Used to give support to tagged controlled objects
-- (see Get_Deep_Controller at s-finimp)
- Num_Interfaces : Natural;
+ Num_Interfaces : Natural;
-- Number of abstract interface types implemented by the tagged type.
-- The value Idepth+Num_Interfaces indicates the end of the second table
-- stored in the Tags_Table component. It is used to implement the
-- purpose we are using the same mechanism as for the Prims_Ptr array in
-- the Dispatch_Table record. See comments below on Prims_Ptr for
-- further details.
+
+ POK_Table : Prim_Op_Kind_Table (1 .. 1);
+ Ent_Index_Table : Entry_Index_Table (1 .. 1);
+ -- Two auxiliary tables used for dispatching in asynchronous,
+ -- conditional and timed selects. Their size depends on the number
+ -- of primitive operations. Indexing in these two tables is performed
+ -- by subtracting the number of predefined primitive operations from
+ -- the given index value. POK_Table contains the callable entity kinds
+ -- of all non-predefined primitive operations. Ent_Index_Table contains
+ -- the entry index of primitive entry wrappers.
end record;
type Dispatch_Table is record
type Storage_Offset_Ptr is access System.Storage_Elements.Storage_Offset;
function To_Storage_Offset_Ptr is
- new Unchecked_Conversion (System.Address, Storage_Offset_Ptr);
+ new Unchecked_Conversion (System.Address, Storage_Offset_Ptr);
-----------------------
-- Local Subprograms --
Str1 : constant Cstring_Ptr := To_Cstring_Ptr (A);
Str2 : constant Cstring_Ptr := To_Cstring_Ptr (B);
J : Integer := 1;
-
begin
loop
if Str1 (J) /= Str2 (J) then
return False;
-
elsif Str1 (J) = ASCII.NUL then
return True;
-
else
J := J + 1;
end if;
-- that are contained in the dispatch table referenced by Obj'Tag.
function IW_Membership
- (This : System.Address;
- Iface_Tag : Tag) return Boolean
+ (This : System.Address;
+ T : Tag) return Boolean
is
- T : constant Tag := To_Tag_Ptr (This).all;
- Obj_Base : constant System.Address := This - Offset_To_Top (T);
- T_Base : constant Tag := To_Tag_Ptr (Obj_Base).all;
+ Curr_DT : constant Tag := To_Tag_Ptr (This).all;
+ Obj_Base : constant System.Address := This - Offset_To_Top (Curr_DT);
+ Obj_DT : constant Tag := To_Tag_Ptr (Obj_Base).all;
- Obj_TSD : constant Type_Specific_Data_Ptr := TSD (T_Base);
- Last_Id : constant Natural := Obj_TSD.Idepth + Obj_TSD.Num_Interfaces;
- Id : Natural;
+ Obj_TSD : constant Type_Specific_Data_Ptr := TSD (Obj_DT);
+ Last_Id : constant Natural := Obj_TSD.Idepth + Obj_TSD.Num_Interfaces;
+ Id : Natural;
begin
if Obj_TSD.Num_Interfaces > 0 then
- Id := Obj_TSD.Idepth + 1;
+
+ -- Traverse the ancestor tags table plus the interface tags table.
+ -- The former part is required to give support to:
+ -- Iface_CW in Typ'Class
+
+ Id := 0;
loop
- if Obj_TSD.Tags_Table (Id) = Iface_Tag then
+ if Obj_TSD.Tags_Table (Id) = T then
return True;
end if;
return TSD (T).Access_Level;
end Get_Access_Level;
+ ---------------------
+ -- Get_Entry_Index --
+ ---------------------
+
+ function Get_Entry_Index
+ (T : Tag;
+ Position : Positive) return Positive is
+ begin
+ return TSD (T).Ent_Index_Table (Position - Default_Prim_Op_Count);
+ end Get_Entry_Index;
+
----------------------
-- Get_External_Tag --
----------------------
return T.Prims_Ptr (Position);
end Get_Prim_Op_Address;
+ ----------------------
+ -- Get_Prim_Op_Kind --
+ ----------------------
+
+ function Get_Prim_Op_Kind
+ (T : Tag;
+ Position : Positive) return Prim_Op_Kind is
+ begin
+ return TSD (T).POK_Table (Position - Default_Prim_Op_Count);
+ end Get_Prim_Op_Kind;
+
-------------------
-- Get_RC_Offset --
-------------------
-- of the parent
New_TSD_Ptr.Tags_Table
- (1 .. New_TSD_Ptr.Idepth + New_TSD_Ptr.Num_Interfaces)
- := Old_TSD_Ptr.Tags_Table
- (0 .. Old_TSD_Ptr.Idepth + Old_TSD_Ptr.Num_Interfaces);
+ (1 .. New_TSD_Ptr.Idepth + New_TSD_Ptr.Num_Interfaces) :=
+ Old_TSD_Ptr.Tags_Table
+ (0 .. Old_TSD_Ptr.Idepth + Old_TSD_Ptr.Num_Interfaces);
else
New_TSD_Ptr.Idepth := 0;
New_TSD_Ptr.Num_Interfaces := 0;
-- The tag of the parent type through the dispatch table
F : constant Acc_Size := To_Acc_Size (Parent_Tag.Prims_Ptr (1));
- -- Access to the _size primitive of the parent. We assume that
- -- it is always in the first slot of the dispatch table
+ -- Access to the _size primitive of the parent. We assume that it is
+ -- always in the first slot of the dispatch table
begin
-- Here we compute the size of the _parent field of the object
TSD (T).Access_Level := Value;
end Set_Access_Level;
+ ---------------------
+ -- Set_Entry_Index --
+ ---------------------
+
+ procedure Set_Entry_Index
+ (T : Tag;
+ Position : Positive;
+ Value : Positive) is
+ begin
+ TSD (T).Ent_Index_Table (Position - Default_Prim_Op_Count) := Value;
+ end Set_Entry_Index;
+
-----------------------
-- Set_Expanded_Name --
-----------------------
T.Prims_Ptr (Position) := Value;
end Set_Prim_Op_Address;
+ ----------------------
+ -- Set_Prim_Op_Kind --
+ ----------------------
+
+ procedure Set_Prim_Op_Kind
+ (T : Tag;
+ Position : Positive;
+ Value : Prim_Op_Kind) is
+ begin
+ TSD (T).POK_Table (Position - Default_Prim_Op_Count) := Value;
+ end Set_Prim_Op_Kind;
+
-------------------
-- Set_RC_Offset --
-------------------
with Unchecked_Conversion;
package Ada.Tags is
-pragma Preelaborate_05 (Tags);
--- In accordance with Ada 2005 AI-362
-
- pragma Elaborate_Body;
- -- We need a dummy body to solve bootstrap path issues (why ???)
+ pragma Preelaborate_05;
+ -- In accordance with Ada 2005 AI-362
type Tag is private;
type Type_Specific_Data;
type Type_Specific_Data_Ptr is access all Type_Specific_Data;
+ -- Primitive operation kinds. These values differentiate the kinds of
+ -- callable entities stored in the dispatch table. Certain kinds may
+ -- not be used, but are added for completeness.
+
+ type Prim_Op_Kind is
+ (POK_Function,
+ POK_Procedure,
+ POK_Protected_Entry,
+ POK_Protected_Function,
+ POK_Protected_Procedure,
+ POK_Task_Entry,
+ POK_Task_Procedure);
+
+ -- Number of predefined primitive operations added by the Expander
+ -- for a tagged type. It is utilized for indexing in the two auxiliary
+ -- tables used for dispatching asynchronous, conditional and timed
+ -- selects. In order to be space efficien, indexing is performed by
+ -- subtracting this constant value from the provided position in the
+ -- auxiliary tables.
+ -- This value is mirrored from Exp_Disp.ads.
+
+ Default_Prim_Op_Count : constant Positive := 14;
+
package SSE renames System.Storage_Elements;
function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean;
-- true if Obj is in Typ'Class.
function IW_Membership
- (This : System.Address;
- Iface_Tag : Tag) return Boolean;
- -- Ada 2005 (AI-251): Given the tag of an object and the tag associated
- -- with an interface, return true if Obj is in Iface'Class.
+ (This : System.Address;
+ T : Tag) return Boolean;
+ -- Ada 2005 (AI-251): General routine that checks if a given object
+ -- implements a tagged type. Its common usage is to check if Obj is in
+ -- Iface'Class, but it is also used to check if a class-wide interface
+ -- implements a given type (Iface_CW_Typ in T'Class). For example:
+ --
+ -- type I is interface;
+ -- type T is tagged ...
+ --
+ -- function Test (O : in I'Class) is
+ -- begin
+ -- return O in T'Class.
+ -- end Test;
function Get_Access_Level (T : Tag) return Natural;
-- Given the tag associated with a type, returns the accessibility level
-- of the type.
+ function Get_Entry_Index
+ (T : Tag;
+ Position : Positive) return Positive;
+ -- Return a primitive operation's entry index (if entry) given a dispatch
+ -- table T and a position of a primitive operation in T.
+
function Get_External_Tag (T : Tag) return System.Address;
-- Retrieve the address of a null terminated string containing
-- the external name
function Get_Prim_Op_Address
(T : Tag;
Position : Positive) return System.Address;
- -- Given a pointer to a dispatch Table (T) and a position in the DT
+ -- Given a pointer to a dispatch table (T) and a position in the DT
-- this function returns the address of the virtual function stored
-- in it (used for dispatching calls)
+ function Get_Prim_Op_Kind
+ (T : Tag;
+ Position : Positive) return Prim_Op_Kind;
+ -- Return a primitive operation's kind given a dispatch table T and a
+ -- position of a primitive operation in T.
+
function Get_RC_Offset (T : Tag) return SSE.Storage_Offset;
-- Return the Offset of the implicit record controller when the object
-- has controlled components. O otherwise.
-- Insert the Tag and its associated external_tag in a table for the
-- sake of Internal_Tag
+ procedure Set_Entry_Index
+ (T : Tag;
+ Position : Positive;
+ Value : Positive);
+ -- Set the entry index of a primitive operation in T's TSD table indexed
+ -- by Position.
+
procedure Set_Offset_To_Top
(T : Tag;
Value : System.Storage_Elements.Storage_Offset);
(T : Tag;
Position : Positive;
Value : System.Address);
- -- Given a pointer to a dispatch Table (T) and a position in the
- -- dispatch Table put the address of the virtual function in it
- -- (used for overriding)
+ -- Given a pointer to a dispatch Table (T) and a position in the dispatch
+ -- Table put the address of the virtual function in it (used for
+ -- overriding).
+
+ procedure Set_Prim_Op_Kind
+ (T : Tag;
+ Position : Positive;
+ Value : Prim_Op_Kind);
+ -- Set the kind of a primitive operation in T's TSD table indexed by
+ -- Position.
procedure Set_TSD (T : Tag; Value : System.Address);
-- Given a pointer T to a dispatch Table, stores the address of the record
- -- containing the Type Specific Data generated by GNAT
+ -- containing the Type Specific Data generated by GNAT.
procedure Set_Access_Level (T : Tag; Value : Natural);
-- Sets the accessibility level of the tagged type associated with T
procedure Set_Expanded_Name (T : Tag; Value : System.Address);
-- Set the address of the string containing the expanded name
- -- in the Dispatch table
+ -- in the Dispatch table.
procedure Set_External_Tag (T : Tag; Value : System.Address);
-- Set the address of the string containing the external tag
- -- in the Dispatch table
+ -- in the Dispatch table.
procedure Set_RC_Offset (T : Tag; Value : SSE.Storage_Offset);
-- Sets the Offset of the implicit record controller when the object
-- Abstract_Interface_Alias Node25
- -- (unused) Node26
+ -- Overridden_Operation Node26
- -- (unused) Node27
+ -- Wrapped_Entity Node27
---------------------------------------------
-- Usage of Flags in Defining Entity Nodes --
-- Has_Specified_Stream_Read Flag192
-- Has_Specified_Stream_Write Flag193
-- Is_Local_Anonymous_Access Flag194
+ -- Is_Primitive_Wrapper Flag195
+ -- Was_Hidden Flag196
- -- (unused) Flag195
- -- (unused) Flag196
-- (unused) Flag197
-- (unused) Flag198
-- (unused) Flag199
function Abstract_Interface_Alias (Id : E) return E is
begin
- pragma Assert
- (Ekind (Id) = E_Procedure or Ekind (Id) = E_Function);
+ pragma Assert (Is_Subprogram (Id));
return Node25 (Id);
end Abstract_Interface_Alias;
return Flag59 (Id);
end Is_Preelaborated;
+ function Is_Primitive_Wrapper (Id : E) return B is
+ begin
+ pragma Assert (Ekind (Id) = E_Procedure);
+ return Flag195 (Id);
+ end Is_Primitive_Wrapper;
+
function Is_Private_Composite (Id : E) return B is
begin
pragma Assert (Is_Type (Id));
return Node22 (Id);
end Original_Record_Component;
+ function Overridden_Operation (Id : E) return E is
+ begin
+ return Node26 (Id);
+ end Overridden_Operation;
+
function Packed_Array_Type (Id : E) return E is
begin
pragma Assert (Is_Array_Type (Id));
return Flag96 (Id);
end Warnings_Off;
+ function Wrapped_Entity (Id : E) return E is
+ begin
+ pragma Assert (Ekind (Id) = E_Procedure
+ and then Is_Primitive_Wrapper (Id));
+ return Node27 (Id);
+ end Wrapped_Entity;
+
+ function Was_Hidden (Id : E) return B is
+ begin
+ return Flag196 (Id);
+ end Was_Hidden;
+
------------------------------
-- Classification Functions --
------------------------------
Set_Flag59 (Id, V);
end Set_Is_Preelaborated;
+ procedure Set_Is_Primitive_Wrapper (Id : E; V : B := True) is
+ begin
+ pragma Assert (Ekind (Id) = E_Procedure);
+ Set_Flag195 (Id, V);
+ end Set_Is_Primitive_Wrapper;
+
procedure Set_Is_Private_Composite (Id : E; V : B := True) is
begin
pragma Assert (Is_Type (Id));
Set_Node22 (Id, V);
end Set_Original_Record_Component;
+ procedure Set_Overridden_Operation (Id : E; V : E) is
+ begin
+ Set_Node26 (Id, V);
+ end Set_Overridden_Operation;
+
procedure Set_Packed_Array_Type (Id : E; V : E) is
begin
pragma Assert (Is_Array_Type (Id));
Set_Flag96 (Id, V);
end Set_Warnings_Off;
+ procedure Set_Was_Hidden (Id : E; V : B := True) is
+ begin
+ Set_Flag196 (Id, V);
+ end Set_Was_Hidden;
+
+ procedure Set_Wrapped_Entity (Id : E; V : E) is
+ begin
+ pragma Assert (Ekind (Id) = E_Procedure
+ and then Is_Primitive_Wrapper (Id));
+ Set_Node27 (Id, V);
+ end Set_Wrapped_Entity;
+
-----------------------------------
-- Field Initialization Routines --
-----------------------------------
return Underlying_Type (Full_View (Id));
end if;
+ -- If we have an incomplete entity that comes from the limited
+ -- view then we return the Underlying_Type of its non-limited
+ -- view.
+
+ elsif From_With_Type (Id)
+ and then Present (Non_Limited_View (Id))
+ then
+ return Underlying_Type (Non_Limited_View (Id));
+
-- Otherwise check for the case where we have a derived type or
-- subtype, and if so get the Underlying_Type of the parent type.
W ("Is_Packed_Array_Type", Flag138 (Id));
W ("Is_Potentially_Use_Visible", Flag9 (Id));
W ("Is_Preelaborated", Flag59 (Id));
+ W ("Is_Primitive_Wrapper", Flag195 (Id));
W ("Is_Private_Composite", Flag107 (Id));
W ("Is_Private_Descendant", Flag53 (Id));
W ("Is_Public", Flag10 (Id));
W ("Uses_Sec_Stack", Flag95 (Id));
W ("Vax_Float", Flag151 (Id));
W ("Warnings_Off", Flag96 (Id));
+ W ("Was_Hidden", Flag196 (Id));
end Write_Entity_Flags;
-----------------------
procedure Write_Field26_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
+ when E_Procedure |
+ E_Function =>
+ Write_Str ("Overridden_Operation");
+
when others =>
Write_Str ("Field26??");
end case;
procedure Write_Field27_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
+ when E_Procedure =>
+ Write_Str ("Wrapped_Entity");
+
when others =>
Write_Str ("Field27??");
end case;
-- dynamic bounds, it is assumed that the value can range down or up
-- to the corresponding bound of the ancestor
--- The RM defined attribute Size corresponds to the Value_Size attribute.
+-- The RM defined attribute Size corresponds to the Value_Size attribute
-- The Size attribute may be defined for a first-named subtype. This sets
-- the Value_Size of the first-named subtype to the given value, and the
-- flag is set does not necesarily mean that no elaboration code is
-- generated for the package.
+-- Is_Primitive_Wrapper (Flag195)
+-- Present in E_Procedures. Primitive wrappers are Expander-generated
+-- procedures that wrap entries of protected or task types implementing
+-- a limited interface.
+
-- Is_Private_Composite (Flag107)
-- Present in composite types that have a private component. Used to
-- enforce the rule that operations on the composite type that depend
-- In subtypes (tagged and untagged):
-- Points to the component in the base type.
+-- Overridden_Operation (Node26)
+-- Present in subprograms. For overriding operations, points to the
+-- user-defined parent subprogram that is being overridden.
+
-- Packed_Array_Type (Node23)
-- Present in array types and subtypes, including the string literal
-- subtype case, if the corresponding type is packed (either bit packed
-- is used to suppress warnings for a given entity. It is also used by
-- the compiler in some situations to kill spurious warnings.
+-- Was_Hidden (Flag196)
+-- Present in all entities. Used to save the value of the Is_Hidden
+-- attribute when the limited-view is installed (Ada 2005: AI-217).
+
+-- Wrapped_Entity (Node27)
+-- Present in an E_Procedure classified as a Is_Primitive_Wrapper. Set
+-- to the entity that is being wrapped.
+
------------------
-- Access Kinds --
------------------
-- A record type, created by a record type declaration
E_Record_Subtype,
- -- A record subtype, created by a record subtype declaration.
+ -- A record subtype, created by a record subtype declaration
E_Record_Type_With_Private,
-- Used for types defined by a private extension declaration, and
-- a private type.
E_Record_Subtype_With_Private,
- -- A subtype of a type defined by a private extension declaration.
+ -- A subtype of a type defined by a private extension declaration
E_Private_Type,
-- A private type, created by a private type declaration
-- Is_Packed_Array_Type (Flag138)
-- Is_Potentially_Use_Visible (Flag9)
-- Is_Preelaborated (Flag59)
+ -- Is_Primitive_Wrapper (Flag195)
-- Is_Public (Flag10)
-- Is_Pure (Flag44)
-- Is_Remote_Call_Interface (Flag62)
-- Referenced_As_LHS (Flag36)
-- Suppress_Elaboration_Warnings (Flag148)
-- Suppress_Style_Checks (Flag165)
+ -- Was_Hidden (Flag196)
-- Declaration_Node (synth)
-- Enclosing_Dynamic_Scope (synth)
-- Privals_Chain (Elist23) (for a protected function)
-- Obsolescent_Warning (Node24)
-- Abstract_Interface_Alias (Node25)
+ -- Overridden_Operation (Node26)
-- Body_Needed_For_SAL (Flag40)
-- Elaboration_Entity_Required (Flag174)
-- Function_Returns_With_DSP (Flag169)
-- Privals_Chain (Elist23) (for a protected procedure)
-- Obsolescent_Warning (Node24)
-- Abstract_Interface_Alias (Node25)
+ -- Overridden_Operation (Node26)
+ -- Wrapped_Entity (Node27) (non-generic case only)
+
-- Body_Needed_For_SAL (Flag40)
-- Elaboration_Entity_Required (Flag174)
-- Function_Returns_With_DSP (Flag169) (always False for procedure)
-- Is_Machine_Code_Subprogram (Flag137) (non-generic case only)
-- Is_Null_Init_Proc (Flag178)
-- Is_Overriding_Operation (Flag39) (non-generic case only)
+ -- Is_Primitive_Wrapper (Flag195) (non-generic case only)
+
-- Is_Private_Descendant (Flag53)
-- Is_Pure (Flag44)
-- Is_Thread_Body (Flag77) (non-generic case only)
function Is_Packed_Array_Type (Id : E) return B;
function Is_Potentially_Use_Visible (Id : E) return B;
function Is_Preelaborated (Id : E) return B;
+ function Is_Primitive_Wrapper (Id : E) return B;
+
function Is_Private_Composite (Id : E) return B;
function Is_Private_Descendant (Id : E) return B;
function Is_Public (Id : E) return B;
function Original_Access_Type (Id : E) return E;
function Original_Array_Type (Id : E) return E;
function Original_Record_Component (Id : E) return E;
+ function Overridden_Operation (Id : E) return E;
function Packed_Array_Type (Id : E) return E;
function Parent_Subtype (Id : E) return E;
function Primitive_Operations (Id : E) return L;
function Uses_Sec_Stack (Id : E) return B;
function Vax_Float (Id : E) return B;
function Warnings_Off (Id : E) return B;
+ function Was_Hidden (Id : E) return B;
+ function Wrapped_Entity (Id : E) return E;
-------------------------------
-- Classification Attributes --
procedure Set_Is_Packed_Array_Type (Id : E; V : B := True);
procedure Set_Is_Potentially_Use_Visible (Id : E; V : B := True);
procedure Set_Is_Preelaborated (Id : E; V : B := True);
+ procedure Set_Is_Primitive_Wrapper (Id : E; V : B := True);
+
procedure Set_Is_Private_Composite (Id : E; V : B := True);
procedure Set_Is_Private_Descendant (Id : E; V : B := True);
procedure Set_Is_Public (Id : E; V : B := True);
procedure Set_Original_Access_Type (Id : E; V : E);
procedure Set_Original_Array_Type (Id : E; V : E);
procedure Set_Original_Record_Component (Id : E; V : E);
+ procedure Set_Overridden_Operation (Id : E; V : E);
procedure Set_Packed_Array_Type (Id : E; V : E);
procedure Set_Parent_Subtype (Id : E; V : E);
procedure Set_Primitive_Operations (Id : E; V : L);
procedure Set_Uses_Sec_Stack (Id : E; V : B := True);
procedure Set_Vax_Float (Id : E; V : B := True);
procedure Set_Warnings_Off (Id : E; V : B := True);
+ procedure Set_Was_Hidden (Id : E; V : B := True);
+ procedure Set_Wrapped_Entity (Id : E; V : E);
-----------------------------------
-- Field Initialization Routines --
pragma Inline (Is_Packed_Array_Type);
pragma Inline (Is_Potentially_Use_Visible);
pragma Inline (Is_Preelaborated);
+ pragma Inline (Is_Primitive_Wrapper);
+
pragma Inline (Is_Private_Composite);
pragma Inline (Is_Private_Descendant);
pragma Inline (Is_Private_Type);
pragma Inline (Original_Access_Type);
pragma Inline (Original_Array_Type);
pragma Inline (Original_Record_Component);
+ pragma Inline (Overridden_Operation);
pragma Inline (Packed_Array_Type);
pragma Inline (Parameter_Mode);
pragma Inline (Parent_Subtype);
pragma Inline (Uses_Sec_Stack);
pragma Inline (Vax_Float);
pragma Inline (Warnings_Off);
+ pragma Inline (Was_Hidden);
+ pragma Inline (Wrapped_Entity);
pragma Inline (Init_Alignment);
pragma Inline (Init_Component_Bit_Offset);
pragma Inline (Set_Is_Packed_Array_Type);
pragma Inline (Set_Is_Potentially_Use_Visible);
pragma Inline (Set_Is_Preelaborated);
+ pragma Inline (Set_Is_Primitive_Wrapper);
+
pragma Inline (Set_Is_Private_Composite);
pragma Inline (Set_Is_Private_Descendant);
pragma Inline (Set_Is_Public);
pragma Inline (Set_Original_Access_Type);
pragma Inline (Set_Original_Array_Type);
pragma Inline (Set_Original_Record_Component);
+ pragma Inline (Set_Overridden_Operation);
pragma Inline (Set_Packed_Array_Type);
pragma Inline (Set_Parent_Subtype);
pragma Inline (Set_Primitive_Operations);
pragma Inline (Set_Uses_Sec_Stack);
pragma Inline (Set_Vax_Float);
pragma Inline (Set_Warnings_Off);
+ pragma Inline (Set_Was_Hidden);
+ pragma Inline (Set_Wrapped_Entity);
-- END XEINFO INLINES
with Atree; use Atree;
with Checks; use Checks;
with Einfo; use Einfo;
-with Elists; use Elists;
with Errout; use Errout;
with Exp_Aggr; use Exp_Aggr;
with Exp_Ch4; use Exp_Ch4;
Parameter_List := Build_Discriminant_Formals (Rec_Id, False);
Set_Parameter_Specifications (Spec_Node, Parameter_List);
- Set_Subtype_Mark (Spec_Node,
- New_Reference_To (Standard_Boolean, Loc));
+ Set_Result_Definition (Spec_Node,
+ New_Reference_To (Standard_Boolean, Loc));
Set_Specification (Body_Node, Spec_Node);
Set_Declarations (Body_Node, New_List);
Attribute_Name => Name_Unrestricted_Access);
end if;
- -- Ada 2005 (AI-231): Generate conversion to the null-excluding
- -- type to force the corresponding run-time check.
+ -- Ada 2005 (AI-231): Add the run-time check if required
if Ada_Version >= Ada_05
- and then Can_Never_Be_Null (Etype (Id)) -- Lhs
- and then Present (Etype (Exp))
- and then not Can_Never_Be_Null (Etype (Exp))
+ and then Can_Never_Be_Null (Etype (Id)) -- Lhs
then
- Rewrite (Exp, Convert_To (Etype (Id), Relocate_Node (Exp)));
- Analyze_And_Resolve (Exp, Etype (Id));
+ if Nkind (Exp) = N_Null then
+ return New_List (
+ Make_Raise_Constraint_Error (Sloc (Exp),
+ Reason => CE_Null_Not_Allowed));
+
+ elsif Present (Etype (Exp))
+ and then not Can_Never_Be_Null (Etype (Exp))
+ then
+ Install_Null_Excluding_Check (Exp);
+ end if;
end if;
-- Take a copy of Exp to ensure that later copies of this
Make_Function_Specification (Loc,
Defining_Unit_Name => F,
Parameter_Specifications => Pspecs,
- Subtype_Mark => New_Reference_To (Standard_Boolean, Loc)),
+ Result_Definition => New_Reference_To (Standard_Boolean, Loc)),
Declarations => New_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
elsif Is_Access_Type (Typ) then
- -- Ada 2005 (AI-231): Generate conversion to the null-excluding
- -- type to force the corresponding run-time check
-
- if Ada_Version >= Ada_05
- and then (Can_Never_Be_Null (Def_Id)
- or else Can_Never_Be_Null (Typ))
- then
- Rewrite
- (Expr_Q,
- Convert_To (Etype (Def_Id), Relocate_Node (Expr_Q)));
- Analyze_And_Resolve (Expr_Q, Etype (Def_Id));
- end if;
-
-- For access types set the Is_Known_Non_Null flag if the
-- initializing value is known to be non-null. We can also set
-- Can_Never_Be_Null if this is a constant.
Make_Defining_Identifier (Loc, Name_uF),
Parameter_Type => New_Reference_To (Standard_Boolean, Loc))),
- Subtype_Mark => New_Reference_To (Standard_Integer, Loc)),
+ Result_Definition => New_Reference_To (Standard_Integer, Loc)),
Declarations => Empty_List,
------------------------
procedure Freeze_Record_Type (N : Node_Id) is
- Def_Id : constant Node_Id := Entity (N);
Comp : Entity_Id;
- Type_Decl : constant Node_Id := Parent (Def_Id);
+ Def_Id : constant Node_Id := Entity (N);
Predef_List : List_Id;
+ Type_Decl : constant Node_Id := Parent (Def_Id);
Renamed_Eq : Node_Id := Empty;
-- Could use some comments ???
Make_Predefined_Primitive_Specs
(Def_Id, Predef_List, Renamed_Eq);
Insert_List_Before_And_Analyze (N, Predef_List);
+
Set_Is_Frozen (Def_Id, True);
Set_All_DT_Position (Def_Id);
Append_Freeze_Actions
(Def_Id, Predefined_Primitive_Freeze (Def_Id));
+ Append_Freeze_Actions
+ (Def_Id, Init_Predefined_Interface_Primitives (Def_Id));
end if;
-- In the non-tagged case, an equality function is provided only for
if Is_Tagged_Type (Def_Id) then
Predef_List := Predefined_Primitive_Bodies (Def_Id, Renamed_Eq);
Append_Freeze_Actions (Def_Id, Predef_List);
- end if;
+ -- Populate the two auxiliary tables used for dispatching
+ -- asynchronous, conditional and timed selects for tagged
+ -- types that implement a limited interface.
+
+ if Ada_Version >= Ada_05
+ and then not Is_Interface (Def_Id)
+ and then not Is_Abstract (Def_Id)
+ and then not Is_Controlled (Def_Id)
+ and then Implements_Limited_Interface (Def_Id)
+ then
+ Append_Freeze_Actions (Def_Id, Make_Disp_Select_Tables (Def_Id));
+ end if;
+ end if;
end Freeze_Record_Type;
------------------------------
Parameter_Type => New_Reference_To (Tag_Typ, Loc)))));
end if;
+ -- Generate the declarations for the following primitive operations:
+ -- disp_asynchronous_select
+ -- disp_conditional_select
+ -- disp_get_prim_op_kind
+ -- disp_timed_select
+ -- for limited interfaces and tagged types that implement a limited
+ -- interface.
+
+ if Ada_Version >= Ada_05
+ and then
+ ((Is_Interface (Tag_Typ)
+ and then Is_Limited_Record (Tag_Typ))
+ or else
+ (not Is_Abstract (Tag_Typ)
+ and then not Is_Controlled (Tag_Typ)
+ and then Implements_Limited_Interface (Tag_Typ)))
+ then
+ if Is_Interface (Tag_Typ) then
+ Append_To (Res,
+ Make_Abstract_Subprogram_Declaration (Loc,
+ Specification =>
+ Make_Disp_Asynchronous_Select_Spec (Tag_Typ)));
+
+ Append_To (Res,
+ Make_Abstract_Subprogram_Declaration (Loc,
+ Specification =>
+ Make_Disp_Conditional_Select_Spec (Tag_Typ)));
+
+ Append_To (Res,
+ Make_Abstract_Subprogram_Declaration (Loc,
+ Specification =>
+ Make_Disp_Get_Prim_Op_Kind_Spec (Tag_Typ)));
+
+ Append_To (Res,
+ Make_Abstract_Subprogram_Declaration (Loc,
+ Specification =>
+ Make_Disp_Timed_Select_Spec (Tag_Typ)));
+
+ else
+ Append_To (Res,
+ Make_Subprogram_Declaration (Loc,
+ Specification =>
+ Make_Disp_Asynchronous_Select_Spec (Tag_Typ)));
+
+ Append_To (Res,
+ Make_Subprogram_Declaration (Loc,
+ Specification =>
+ Make_Disp_Conditional_Select_Spec (Tag_Typ)));
+
+ Append_To (Res,
+ Make_Subprogram_Declaration (Loc,
+ Specification =>
+ Make_Disp_Get_Prim_Op_Kind_Spec (Tag_Typ)));
+
+ Append_To (Res,
+ Make_Subprogram_Declaration (Loc,
+ Specification =>
+ Make_Disp_Timed_Select_Spec (Tag_Typ)));
+ end if;
+ end if;
+
-- Specs for finalization actions that may be required in case a
-- future extension contain a controlled element. We generate those
-- only for root tagged types where they will get dummy bodies or
Make_Function_Specification (Loc,
Defining_Unit_Name => Id,
Parameter_Specifications => Profile,
- Subtype_Mark =>
+ Result_Definition =>
New_Reference_To (Ret_Type, Loc));
end if;
end if;
end if;
+ -- Generate the bodies for the following primitive operations:
+ -- disp_asynchronous_select
+ -- disp_conditional_select
+ -- disp_get_prim_op_kind
+ -- disp_timed_select
+ -- for tagged types that implement a limited interface.
+
+ if Ada_Version >= Ada_05
+ and then not Is_Interface (Tag_Typ)
+ and then not Is_Abstract (Tag_Typ)
+ and then not Is_Controlled (Tag_Typ)
+ and then Implements_Limited_Interface (Tag_Typ)
+ then
+ Append_To (Res,
+ Make_Disp_Asynchronous_Select_Body (Tag_Typ));
+ Append_To (Res,
+ Make_Disp_Conditional_Select_Body (Tag_Typ));
+ Append_To (Res,
+ Make_Disp_Get_Prim_Op_Kind_Body (Tag_Typ));
+ Append_To (Res,
+ Make_Disp_Timed_Select_Body (Tag_Typ));
+ end if;
+
if not Is_Limited_Type (Tag_Typ) then
-- Body for equality
end if;
Set_Elaboration_Flag (N, Corresponding_Spec (N));
-
- -- Generate a subprogram descriptor for the elaboration routine of
- -- a package body if the package body has no pending instantiations
- -- and it has generated at least one exception handler
-
- if Present (Handler_Records (Body_Entity (Ent)))
- and then Is_Compilation_Unit (Ent)
- and then not Delay_Subprogram_Descriptors (Body_Entity (Ent))
- then
- Generate_Subprogram_Descriptor_For_Package
- (N, Body_Entity (Ent));
- end if;
-
Set_In_Package_Body (Ent, False);
-- Set to encode entity names in package body before gigi is called
or else Has_Interrupt_Handler (Pid)
or else (Has_Attach_Handler (Pid)
and then not Restricted_Profile)
+ or else (Ada_Version >= Ada_05
+ and then Present (Interface_List (Parent (Pid))))
then
if Abort_Allowed
or else Restriction_Active (No_Entry_Queue) = False
with Stand; use Stand;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
-with Types; use Types;
with Uintp; use Uintp;
package body Exp_Ch9 is
+ --------------------------------
+ -- Select_Expansion_Utilities --
+ --------------------------------
+
+ -- The following package contains helper routines used in the expansion of
+ -- dispatching asynchronous, conditional and timed selects.
+
+ package Select_Expansion_Utilities is
+ function Build_Abort_Block
+ (Loc : Source_Ptr;
+ Blk_Ent : Entity_Id;
+ Blk : Node_Id) return Node_Id;
+ -- Generate:
+ -- begin
+ -- Blk
+ -- exception
+ -- when Abort_Signal => Abort_Undefer;
+ -- end;
+ -- Blk_Ent is the name of the encapsulated block, Blk is the actual
+ -- block node.
+
+ function Build_B
+ (Loc : Source_Ptr;
+ Decls : List_Id) return Entity_Id;
+ -- Generate:
+ -- B : Boolean := False;
+ -- Append the object declaration to the list and return the name of
+ -- the object.
+
+ function Build_C
+ (Loc : Source_Ptr;
+ Decls : List_Id) return Entity_Id;
+ -- Generate:
+ -- C : Ada.Tags.Prim_Op_Kind;
+ -- Append the object declaration to the list and return the name of
+ -- the object.
+
+ function Build_Cleanup_Block
+ (Loc : Source_Ptr;
+ Blk_Ent : Entity_Id;
+ Stmts : List_Id;
+ Clean_Ent : Entity_Id) return Node_Id;
+ -- Generate:
+ -- declare
+ -- procedure _clean is
+ -- begin
+ -- ...
+ -- end _clean;
+ -- begin
+ -- Stmts
+ -- at end
+ -- _clean;
+ -- end;
+ -- Blk_Ent is the name of the generated block, Stmts is the list
+ -- of encapsulated statements and Clean_Ent is the parameter to
+ -- the _clean procedure.
+
+ function Build_S
+ (Loc : Source_Ptr;
+ Decls : List_Id;
+ Call_Ent : Entity_Id) return Entity_Id;
+ -- Generate:
+ -- S : constant Integer := DT_Position (Call_Ent);
+ -- where Call_Ent is the entity of the dispatching call name. Append
+ -- the object declaration to the list and return the name of the
+ -- object.
+
+ function Build_Wrapping_Procedure
+ (Loc : Source_Ptr;
+ Nam : Character;
+ Decls : List_Id;
+ Stmts : List_Id) return Entity_Id;
+ -- Generate:
+ -- procedure <temp>Nam is
+ -- begin
+ -- Stmts
+ -- end <temp>Nam;
+ -- where Nam is the generated procedure name and Stmts are the
+ -- encapsulated statements. Append the procedure body to Decls.
+ -- Return the internally generated procedure name.
+ end Select_Expansion_Utilities;
+
+ package body Select_Expansion_Utilities is
+
+ -----------------------
+ -- Build_Abort_Block --
+ -----------------------
+
+ function Build_Abort_Block
+ (Loc : Source_Ptr;
+ Blk_Ent : Entity_Id;
+ Blk : Node_Id) return Node_Id
+ is
+ begin
+ return
+ Make_Block_Statement (Loc,
+ Declarations =>
+ No_List,
+
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements =>
+ New_List (
+ Make_Implicit_Label_Declaration (Loc,
+ Defining_Identifier =>
+ Blk_Ent,
+ Label_Construct =>
+ Blk),
+ Blk),
+
+ Exception_Handlers =>
+ New_List (
+ Make_Exception_Handler (Loc,
+ Exception_Choices =>
+ New_List (
+ New_Reference_To (Stand.Abort_Signal, Loc)),
+ Statements =>
+ New_List (
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (RTE (
+ RE_Abort_Undefer), Loc),
+ Parameter_Associations => No_List))))));
+ end Build_Abort_Block;
+
+ -------------
+ -- Build_B --
+ -------------
+
+ function Build_B
+ (Loc : Source_Ptr;
+ Decls : List_Id) return Entity_Id
+ is
+ B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
+
+ begin
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ B,
+ Object_Definition =>
+ New_Reference_To (Standard_Boolean, Loc),
+ Expression =>
+ New_Reference_To (Standard_False, Loc)));
+
+ return B;
+ end Build_B;
+
+ -------------
+ -- Build_C --
+ -------------
+
+ function Build_C
+ (Loc : Source_Ptr;
+ Decls : List_Id) return Entity_Id
+ is
+ C : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uC);
+
+ begin
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ C,
+ Object_Definition =>
+ New_Reference_To (RTE (RE_Prim_Op_Kind), Loc)));
+
+ return C;
+ end Build_C;
+
+ -------------------------
+ -- Build_Cleanup_Block --
+ -------------------------
+
+ function Build_Cleanup_Block
+ (Loc : Source_Ptr;
+ Blk_Ent : Entity_Id;
+ Stmts : List_Id;
+ Clean_Ent : Entity_Id) return Node_Id
+ is
+ Cleanup_Block : constant Node_Id :=
+ Make_Block_Statement (Loc,
+ Identifier => New_Reference_To (Blk_Ent, Loc),
+ Declarations => No_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Stmts),
+ Is_Asynchronous_Call_Block => True);
+
+ begin
+ Set_Entry_Cancel_Parameter (Blk_Ent, Clean_Ent);
+
+ return Cleanup_Block;
+ end Build_Cleanup_Block;
+
+ -------------
+ -- Build_S --
+ -------------
+
+ function Build_S
+ (Loc : Source_Ptr;
+ Decls : List_Id;
+ Call_Ent : Entity_Id) return Entity_Id
+ is
+ S : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uS);
+
+ begin
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => S,
+ Constant_Present => True,
+ Object_Definition =>
+ New_Reference_To (Standard_Integer, Loc),
+ Expression =>
+ Make_Integer_Literal (Loc,
+ Intval => DT_Position (Call_Ent))));
+
+ return S;
+ end Build_S;
+
+ ------------------------------
+ -- Build_Wrapping_Procedure --
+ ------------------------------
+
+ function Build_Wrapping_Procedure
+ (Loc : Source_Ptr;
+ Nam : Character;
+ Decls : List_Id;
+ Stmts : List_Id) return Entity_Id
+ is
+ Proc_Nam : constant Entity_Id :=
+ Make_Defining_Identifier (Loc, New_Internal_Name (Nam));
+ begin
+ Append_To (Decls,
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name =>
+ Proc_Nam),
+ Declarations =>
+ No_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements =>
+ New_Copy_List (Stmts))));
+
+ return Proc_Nam;
+ end Build_Wrapping_Procedure;
+ end Select_Expansion_Utilities;
+
+ package SEU renames Select_Expansion_Utilities;
+
-----------------------
-- Local Subprograms --
-----------------------
-- the expression computed by this function uses the discriminants
-- of the target task.
- function Index_Constant_Declaration
- (N : Node_Id;
- Index_Id : Entity_Id;
- Prot : Entity_Id) return List_Id;
- -- For an entry family and its barrier function, we define a local entity
- -- that maps the index in the call into the entry index into the object:
- --
- -- I : constant Index_Type := Index_Type'Val (
- -- E - <<index of first family member>> +
- -- Protected_Entry_Index (Index_Type'Pos (Index_Type'First)));
-
procedure Add_Object_Pointer
(Decls : List_Id;
Pid : Entity_Id;
-- of the System.Address pointer passed to entry barrier functions
-- and entry body procedures.
- function Build_Accept_Body (Astat : Node_Id) return Node_Id;
+ function Build_Accept_Body (Astat : Node_Id) return Node_Id;
-- Transform accept statement into a block with added exception handler.
-- Used both for simple accept statements and for accept alternatives in
-- select statements. Astat is the accept statement.
-- of the range of each entry family. A single array with that size is
-- allocated for each concurrent object of the type.
+ function Build_Parameter_Block
+ (Loc : Source_Ptr;
+ Actuals : List_Id;
+ Formals : List_Id;
+ Decls : List_Id) return Entity_Id;
+ -- Generate an access type for each actual parameter in the list Actuals.
+ -- Cleate an encapsulating record that contains all the actuals and return
+ -- its type. Generate:
+ -- type Ann1 is access all <actual1-type>
+ -- ...
+ -- type AnnN is access all <actualN-type>
+ -- type Pnn is record
+ -- <formal1> : Ann1;
+ -- ...
+ -- <formalN> : AnnN;
+ -- end record;
+
function Build_Wrapper_Body
(Loc : Source_Ptr;
Proc_Nam : Entity_Id;
-- to the use of 'Length on the index type, but must use Family_Offset
-- to handle properly the case of bounds that depend on discriminants.
+ procedure Extract_Dispatching_Call
+ (N : Node_Id;
+ Call_Ent : out Entity_Id;
+ Object : out Entity_Id;
+ Actuals : out List_Id;
+ Formals : out List_Id);
+ -- Given a dispatching call, extract the entity of the name of the call,
+ -- its object parameter, its actual parameters and the formal parameters
+ -- of the overriden interface-level version.
+
procedure Extract_Entry
(N : Node_Id;
Concval : out Node_Id;
-- when P is Name_uPriority, the call will also find Interrupt_Priority.
-- ??? Should be implemented with the rep item chain mechanism.
+ function Index_Constant_Declaration
+ (N : Node_Id;
+ Index_Id : Entity_Id;
+ Prot : Entity_Id) return List_Id;
+ -- For an entry family and its barrier function, we define a local entity
+ -- that maps the index in the call into the entry index into the object:
+ --
+ -- I : constant Index_Type := Index_Type'Val (
+ -- E - <<index of first family member>> +
+ -- Protected_Entry_Index (Index_Type'Pos (Index_Type'First)));
+
+ function Parameter_Block_Pack
+ (Loc : Source_Ptr;
+ Blk_Typ : Entity_Id;
+ Actuals : List_Id;
+ Formals : List_Id;
+ Decls : List_Id;
+ Stmts : List_Id) return Node_Id;
+ -- Set the components of the generated parameter block with the values of
+ -- the actual parameters. Generate aliased temporaries to capture the
+ -- values for types that are passed by copy. Otherwise generate a reference
+ -- to the actual's value. Return the address of the aggregate block.
+ -- Generate:
+ -- Jnn1 : alias <formal-type1>;
+ -- Jnn1 := <actual1>;
+ -- ...
+ -- P : Blk_Typ := (
+ -- Jnn1'unchecked_access;
+ -- <actual2>'reference;
+ -- ...);
+
+ function Parameter_Block_Unpack
+ (Loc : Source_Ptr;
+ Actuals : List_Id;
+ Formals : List_Id) return List_Id;
+ -- Retrieve the values of the components from the parameter block and
+ -- assign then to the original actual parameters. Generate:
+ -- <actual1> := P.<formal1>;
+ -- ...
+ -- <actualN> := P.<formalN>;
+
procedure Update_Prival_Subtypes (N : Node_Id);
-- The actual subtypes of the privals will differ from the type of the
-- private declaration in the original protected type, if the protected
elsif Has_Interrupt_Handler (Typ) then
Protection_Type := RE_Dynamic_Interrupt_Protection;
- elsif Has_Entries (Typ) then
+ -- The type has explicit entries or generated primitive entry
+ -- wrappers.
+
+ elsif Has_Entries (Typ)
+ or else (Ada_Version >= Ada_05
+ and then Present (Interface_List (Parent (Typ))))
+ then
if Abort_Allowed
or else Restriction_Active (No_Entry_Queue) = False
or else Number_Entries (Typ) > 1
Parameter_Type =>
New_Reference_To (RTE (RE_Protected_Entry_Index), Loc))),
- Subtype_Mark => New_Reference_To (Standard_Boolean, Loc));
+ Result_Definition => New_Reference_To (Standard_Boolean, Loc));
end Build_Barrier_Function_Specification;
--------------------------
return Ecount;
end Build_Entry_Count_Expression;
- ------------------------------
+ ---------------------------
+ -- Build_Parameter_Block --
+ ---------------------------
+
+ function Build_Parameter_Block
+ (Loc : Source_Ptr;
+ Actuals : List_Id;
+ Formals : List_Id;
+ Decls : List_Id) return Entity_Id
+ is
+ Actual : Entity_Id;
+ Comp_Nam : Node_Id;
+ Comp_Rec : Node_Id;
+ Comps : List_Id;
+ Formal : Entity_Id;
+
+ begin
+ Actual := First (Actuals);
+ Comps := New_List;
+ Formal := Defining_Identifier (First (Formals));
+ while Present (Actual) loop
+ -- Generate:
+ -- type Ann is access all <actual-type>
+
+ Comp_Nam :=
+ Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
+
+ Append_To (Decls,
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier =>
+ Comp_Nam,
+ Type_Definition =>
+ Make_Access_To_Object_Definition (Loc,
+ All_Present =>
+ True,
+ Constant_Present =>
+ Ekind (Formal) = E_In_Parameter,
+ Subtype_Indication =>
+ New_Reference_To (Etype (Actual), Loc))));
+
+ -- Generate:
+ -- Param : Ann;
+
+ Append_To (Comps,
+ Make_Component_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Chars (Formal)),
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present =>
+ False,
+ Subtype_Indication =>
+ New_Reference_To (Comp_Nam, Loc))));
+
+ Next_Actual (Actual);
+ Next_Formal_With_Extras (Formal);
+ end loop;
+
+ -- Generate:
+ -- type Pnn is record
+ -- Param1 : Ann1;
+ -- ...
+ -- ParamN : AnnN;
+
+ -- where Pnn is a parameter wrapping record, Param1 .. ParamN are the
+ -- original parameter names and Ann1 .. AnnN are the access to actual
+ -- types.
+
+ Comp_Rec :=
+ Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
+
+ Append_To (Decls,
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier =>
+ Comp_Rec,
+ Type_Definition =>
+ Make_Record_Definition (Loc,
+ Component_List =>
+ Make_Component_List (Loc, Comps))));
+
+ return Comp_Rec;
+ end Build_Parameter_Block;
+
+ ------------------------
-- Build_Wrapper_Body --
- ------------------------------
+ ------------------------
function Build_Wrapper_Body
(Loc : Source_Ptr;
if Ekind (Proc_Nam) = E_Procedure
or else Ekind (Proc_Nam) = E_Entry
then
- Set_Ekind (New_Name_Id, E_Procedure);
+ Set_Ekind (New_Name_Id, E_Procedure);
+ Set_Is_Primitive_Wrapper (New_Name_Id);
+ Set_Wrapped_Entity (New_Name_Id, Proc_Nam);
+
return
Make_Procedure_Specification (Loc,
Defining_Unit_Name => New_Name_Id,
else pragma Assert (Ekind (Proc_Nam) = E_Function);
Set_Ekind (New_Name_Id, E_Function);
+
return
Make_Function_Specification (Loc,
Defining_Unit_Name => New_Name_Id,
Parameter_Specifications => New_Formals,
- Subtype_Mark => New_Copy (Subtype_Mark (Parent (Proc_Nam))));
+ Result_Definition =>
+ New_Copy (Result_Definition (Parent (Proc_Nam))));
end if;
end Build_Wrapper_Spec;
Defining_Identifier => Parm2,
Parameter_Type =>
New_Reference_To (RTE (RE_Protected_Entry_Index), Loc))),
- Subtype_Mark => New_Occurrence_Of (
+ Result_Definition => New_Occurrence_Of (
RTE (RE_Protected_Entry_Index), Loc));
end Build_Find_Body_Index_Spec;
---------------------------------------
function Build_Protected_Sub_Specification
- (N : Node_Id;
- Prottyp : Entity_Id;
- Unprotected : Boolean := False) return Node_Id
+ (N : Node_Id;
+ Prottyp : Entity_Id;
+ Mode : Subprogram_Protection_Mode) return Node_Id
is
- Loc : constant Source_Ptr := Sloc (N);
- Decl : Node_Id;
- Protnm : constant Name_Id := Chars (Prottyp);
- Ident : Entity_Id;
- Nam : Name_Id;
- New_Id : Entity_Id;
- New_Plist : List_Id;
- Append_Char : Character;
- New_Spec : Node_Id;
+ Loc : constant Source_Ptr := Sloc (N);
+ Decl : Node_Id;
+ Protnm : constant Name_Id := Chars (Prottyp);
+ Ident : Entity_Id;
+ Nam : Name_Id;
+ New_Id : Entity_Id;
+ New_Plist : List_Id;
+ New_Spec : Node_Id;
+
+ Append_Chr : constant array (Subprogram_Protection_Mode) of Character :=
+ (Dispatching_Mode => ' ',
+ Protected_Mode => 'P',
+ Unprotected_Mode => 'N');
begin
if Ekind
Ident := Defining_Unit_Name (Specification (Decl));
Nam := Chars (Ident);
- New_Plist := Build_Protected_Spec
- (Decl, Corresponding_Record_Type (Prottyp),
- Unprotected, Ident);
-
- if Unprotected then
- Append_Char := 'N';
- else
- -- Ada 2005 (AI-345): The protected version no longer uses 'P'
- -- as suffix in order to make it a primitive operation
-
- if Ada_Version >= Ada_05 then
- Append_Char := ' ';
- else
- Append_Char := 'P';
- end if;
- end if;
+ New_Plist :=
+ Build_Protected_Spec (Decl,
+ Corresponding_Record_Type (Prottyp),
+ Mode = Unprotected_Mode, Ident);
New_Id :=
Make_Defining_Identifier (Loc,
- Chars => Build_Selected_Name (Protnm, Nam, Append_Char));
+ Chars => Build_Selected_Name (Protnm, Nam, Append_Chr (Mode)));
-- The unprotected operation carries the user code, and debugging
-- information must be generated for it, even though this spec does
Make_Function_Specification (Loc,
Defining_Unit_Name => New_Id,
Parameter_Specifications => New_Plist,
- Subtype_Mark => New_Copy (Subtype_Mark (Specification (Decl))));
+ Result_Definition =>
+ New_Copy (Result_Definition (Specification (Decl))));
Set_Return_Present (Defining_Unit_Name (New_Spec));
return New_Spec;
end if;
Exc_Safe := Is_Exception_Safe (N);
P_Op_Spec :=
- Build_Protected_Sub_Specification (N,
- Pid, Unprotected => False);
+ Build_Protected_Sub_Specification (N, Pid, Protected_Mode);
-- Build a list of the formal parameters of the protected
-- version of the subprogram to use as the actual parameters
Make_Object_Declaration (Loc,
Defining_Identifier => R,
Constant_Present => True,
- Object_Definition => New_Copy (Subtype_Mark (N_Op_Spec)),
+ Object_Definition => New_Copy (Result_Definition (N_Op_Spec)),
Expression =>
Make_Function_Call (Loc,
Name => Make_Identifier (Loc,
if Has_Entries (Pid)
or else Has_Interrupt_Handler (Pid)
- or else (Has_Attach_Handler (Pid) and then not Restricted_Profile)
+ or else (Has_Attach_Handler (Pid)
+ and then not Restricted_Profile)
+ or else (Ada_Version >= Ada_05
+ and then Present (Interface_List (Parent (Pid))))
then
if Abort_Allowed
or else Restriction_Active (No_Entry_Queue) = False
Op_Decls := Declarations (N);
N_Op_Spec :=
- Build_Protected_Sub_Specification
- (N, Pid, Unprotected => True);
+ Build_Protected_Sub_Specification (N, Pid, Unprotected_Mode);
return
Make_Subprogram_Body (Loc,
Def1 :=
Make_Access_Function_Definition (Loc,
Parameter_Specifications => P_List,
- Subtype_Mark => New_Copy (Subtype_Mark (Type_Definition (N))));
+ Result_Definition =>
+ New_Copy (Result_Definition (Type_Definition (N))));
else
Def1 :=
-- Expand_N_Asynchronous_Select --
----------------------------------
- -- This procedure assumes that the trigger statement is an entry call. A
- -- delay alternative should already have been expanded into an entry call
- -- to the appropriate delay object Wait entry.
+ -- This procedure assumes that the trigger statement is an entry call or
+ -- a dispatching procedure call. A delay alternative should already have
+ -- been expanded into an entry call to the appropriate delay object Wait
+ -- entry.
-- If the trigger is a task entry call, the select is implemented with
-- a Task_Entry_Call:
-- begin
-- begin
-- Abort_Undefer;
- -- abortable-part
+ -- <abortable-part>
-- at end
-- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions.
-- end;
-
-- exception
- -- when Abort_Signal => Abort_Undefer;
+ -- when Abort_Signal => Abort_Undefer;
-- end;
+
-- parm := P.param;
-- parm := P.param;
-- ...
-- if not C then
- -- triggered-statements
+ -- <triggered-statements>
-- end if;
-- end;
-- Mode => Asynchronous_Call;
-- Block => Bnn);
-- if Enqueued (Bnn) then
- -- <abortable part>
+ -- <abortable-part>
-- end if;
-- at end
-- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions.
-- end;
-
-- exception
- -- when Abort_Signal =>
- -- Abort_Undefer;
- -- null;
+ -- when Abort_Signal => Abort_Undefer;
-- end;
-- if not Cancelled (Bnn) then
- -- triggered statements
+ -- <triggered-statements>
-- end if;
-- end;
-- ...
-- end;
+ -- Ada 2005 (AI-345): If the trigger is a dispatching call, the select is
+ -- expanded into:
+
+ -- declare
+ -- B : Boolean := False;
+ -- Bnn : Communication_Block;
+ -- C : Ada.Tags.Prim_Op_Kind;
+ -- P : Parameters := (Param1 .. ParamN)
+ -- S : constant Integer := DT_Position (<dispatching-call>);
+ -- U : Boolean;
+
+ -- procedure <temp>A is
+ -- begin
+ -- <abortable-statements>
+ -- end <temp>A;
+
+ -- procedure <temp>T is
+ -- begin
+ -- <triggered-statements>
+ -- end <temp>T;
+
+ -- begin
+ -- disp_get_prim_op_kind (<object>, S, C);
+
+ -- if C = POK_Protected_Entry then
+ -- declare
+ -- procedure _clean is
+ -- begin
+ -- if Enqueued (Bnn) then
+ -- Cancel_Protected_Entry_Call (Bnn);
+ -- end if;
+ -- end _clean;
+
+ -- begin
+ -- begin
+ -- disp_asynchronous_select
+ -- (Obj, S, P'address, Bnn, B);
+
+ -- Param1 := P.Param1;
+ -- ...
+ -- ParamN := P.ParamN;
+
+ -- if Enqueued (Bnn) then
+ -- <temp>A;
+ -- end if;
+ -- at end
+ -- _clean;
+ -- end;
+ -- exception
+ -- when Abort_Signal => Abort_Undefer;
+ -- end;
+
+ -- if not Cancelled (Bnn) then
+ -- <temp>T;
+ -- end if;
+
+ -- elsif C = POK_Task_Entry then
+ -- declare
+ -- procedure _clean is
+ -- begin
+ -- Cancel_Task_Entry_Call (U);
+ -- end _clean;
+
+ -- begin
+ -- Abort_Defer;
+
+ -- disp_asynchronous_select
+ -- (<object>, S, P'address, Bnn, B);
+
+ -- Param1 := P.Param1;
+ -- ...
+ -- ParamN := P.ParamN;
+
+ -- begin
+ -- begin
+ -- Abort_Undefer;
+ -- <temp>A;
+ -- at end
+ -- _clean;
+ -- end;
+ -- exception
+ -- when Abort_Signal => Abort_Undefer;
+ -- end;
+
+ -- if not U then
+ -- <temp>T;
+ -- end if;
+ -- end;
+
+ -- else
+ -- <dispatching-call>;
+ -- <temp>T;
+ -- end if;
+
-- The job is to convert this to the asynchronous form
-- If the trigger is a delay statement, it will have been expanded into a
procedure Expand_N_Asynchronous_Select (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
- Trig : constant Node_Id := Triggering_Alternative (N);
Abrt : constant Node_Id := Abortable_Part (N);
- Tstats : constant List_Id := Statements (Trig);
Astats : constant List_Id := Statements (Abrt);
+ Trig : constant Node_Id := Triggering_Alternative (N);
+ Tstats : constant List_Id := Statements (Trig);
- Ecall : Node_Id;
+ Abortable_Block : Node_Id;
+ Actuals : List_Id;
+ Aproc : Entity_Id;
+ Blk_Ent : Entity_Id;
+ Blk_Typ : Entity_Id;
+ Call : Node_Id;
+ Call_Ent : Entity_Id;
+ Cancel_Param : Entity_Id;
+ Cleanup_Block : Node_Id;
+ Cleanup_Stmts : List_Id;
Concval : Node_Id;
- Ename : Node_Id;
- Index : Node_Id;
- Hdle : List_Id;
- Decls : List_Id;
+ Dblock_Ent : Entity_Id;
Decl : Node_Id;
- Parms : List_Id;
- Parm : Node_Id;
- Call : Node_Id;
- Stmts : List_Id;
+ Decls : List_Id;
+ Ecall : Node_Id;
+ Ename : Node_Id;
Enqueue_Call : Node_Id;
- Stmt : Node_Id;
- B : Entity_Id;
- Pdef : Entity_Id;
- Dblock_Ent : Entity_Id;
+ Formals : List_Id;
+ Hdle : List_Id;
+ Index : Node_Id;
N_Orig : Node_Id;
- Abortable_Block : Node_Id;
- Cancel_Param : Entity_Id;
- Blkent : Entity_Id;
+ Obj : Entity_Id;
+ Param : Node_Id;
+ Params : List_Id;
+ Pdef : Entity_Id;
+ ProtE_Stmts : List_Id;
+ ProtP_Stmts : List_Id;
+ Stmt : Node_Id;
+ Stmts : List_Id;
Target_Undefer : RE_Id;
+ TaskE_Stmts : List_Id;
+ Tproc : Entity_Id;
Undefer_Args : List_Id := No_List;
+ B : Entity_Id; -- Call status flag
+ Bnn : Entity_Id; -- Communication block
+ C : Entity_Id; -- Call kind
+ P : Node_Id; -- Parameter block
+ S : Entity_Id; -- Primitive operation slot
+ U : Entity_Id; -- Additional status flag
+
begin
- Blkent := Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
- Ecall := Triggering_Statement (Trig);
+ Blk_Ent := Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
+ Ecall := Triggering_Statement (Trig);
-- The arguments in the call may require dynamic allocation, and the
-- call statement may have been transformed into a block. The block
if Nkind (Ecall) = N_Block_Statement then
Ecall := First (Statements (Handled_Statement_Sequence (Ecall)));
-
while Nkind (Ecall) /= N_Procedure_Call_Statement
and then Nkind (Ecall) /= N_Entry_Call_Statement
loop
end loop;
end if;
- -- If a delay was used as a trigger, it will have been expanded
- -- into a procedure call. Convert it to the appropriate sequence of
- -- statements, similar to what is done for a task entry call.
- -- Note that this currently supports only Duration, Real_Time.Time,
- -- and Calendar.Time.
+ -- This is either a dispatching call or a delay statement used as a
+ -- trigger which was expanded into a procedure call.
if Nkind (Ecall) = N_Procedure_Call_Statement then
+ if Ada_Version >= Ada_05
+ and then
+ (not Present (Original_Node (Ecall))
+ or else
+ Nkind (Original_Node (Ecall)) /= N_Delay_Relative_Statement)
+ then
+ Extract_Dispatching_Call (Ecall, Call_Ent, Obj, Actuals, Formals);
- -- Add a Delay_Block object to the parameter list of the
- -- delay procedure to form the parameter list of the Wait
- -- entry call.
-
- Dblock_Ent := Make_Defining_Identifier (Loc, New_Internal_Name ('D'));
+ Decls := New_List;
+ Stmts := New_List;
- Pdef := Entity (Name (Ecall));
+ -- Call status flag processing, generate:
+ -- B : Boolean := False;
- if Is_RTE (Pdef, RO_CA_Delay_For) then
- Enqueue_Call := New_Reference_To (RTE (RE_Enqueue_Duration), Loc);
+ B := SEU.Build_B (Loc, Decls);
- elsif Is_RTE (Pdef, RO_CA_Delay_Until) then
- Enqueue_Call := New_Reference_To (RTE (RE_Enqueue_Calendar), Loc);
+ -- Communication block processing, generate:
+ -- Bnn : Communication_Block;
- else pragma Assert (Is_RTE (Pdef, RO_RT_Delay_Until));
- Enqueue_Call := New_Reference_To (RTE (RE_Enqueue_RT), Loc);
- end if;
+ Bnn := Make_Defining_Identifier (Loc, New_Internal_Name ('B'));
- Append_To (Parameter_Associations (Ecall),
- Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (Dblock_Ent, Loc),
- Attribute_Name => Name_Unchecked_Access));
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Bnn,
+ Object_Definition =>
+ New_Reference_To (RTE (RE_Communication_Block), Loc)));
- -- Create the inner block to protect the abortable part
+ -- Call kind processing, generate:
+ -- C : Ada.Tags.Prim_Op_Kind;
- Hdle := New_List (
- Make_Exception_Handler (Loc,
- Exception_Choices =>
- New_List (New_Reference_To (Stand.Abort_Signal, Loc)),
- Statements => New_List (
- Make_Procedure_Call_Statement (Loc,
- Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc)))));
+ C := SEU.Build_C (Loc, Decls);
- Prepend_To (Astats,
- Make_Procedure_Call_Statement (Loc,
- Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc)));
+ -- Parameter block processing
- Abortable_Block :=
- Make_Block_Statement (Loc,
- Identifier => New_Reference_To (Blkent, Loc),
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Astats),
- Has_Created_Identifier => True,
- Is_Asynchronous_Call_Block => True);
+ Blk_Typ := Build_Parameter_Block
+ (Loc, Actuals, Formals, Decls);
+ P := Parameter_Block_Pack
+ (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts);
- -- Append call to if Enqueue (When, DB'Unchecked_Access) then
+ -- Dispatch table slot processing, generate:
+ -- S : constant Integer :=
+ -- DT_Position (<dispatching-procedure>);
- Rewrite (Ecall,
- Make_Implicit_If_Statement (N,
- Condition => Make_Function_Call (Loc,
- Name => Enqueue_Call,
- Parameter_Associations => Parameter_Associations (Ecall)),
- Then_Statements =>
- New_List (Make_Block_Statement (Loc,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (
- Make_Implicit_Label_Declaration (Loc,
- Defining_Identifier => Blkent,
- Label_Construct => Abortable_Block),
- Abortable_Block),
- Exception_Handlers => Hdle)))));
+ S := SEU.Build_S (Loc, Decls, Call_Ent);
- Stmts := New_List (Ecall);
+ -- Additional status flag processing, generate:
- -- Construct statement sequence for new block
+ U := Make_Defining_Identifier (Loc, Name_uU);
- Append_To (Stmts,
- Make_Implicit_If_Statement (N,
- Condition => Make_Function_Call (Loc,
- Name => New_Reference_To (
- RTE (RE_Timed_Out), Loc),
- Parameter_Associations => New_List (
- Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (Dblock_Ent, Loc),
- Attribute_Name => Name_Unchecked_Access))),
- Then_Statements => Tstats));
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ U,
+ Object_Definition =>
+ New_Reference_To (Standard_Boolean, Loc)));
- -- The result is the new block
+ -- Generate:
+ -- procedure <temp>A is
+ -- begin
+ -- Astmts
+ -- end <temp>A;
- Set_Entry_Cancel_Parameter (Blkent, Dblock_Ent);
+ Aproc := SEU.Build_Wrapping_Procedure (Loc, 'A', Decls, Astats);
- Rewrite (N,
- Make_Block_Statement (Loc,
- Declarations => New_List (
- Make_Object_Declaration (Loc,
- Defining_Identifier => Dblock_Ent,
- Aliased_Present => True,
- Object_Definition => New_Reference_To (
- RTE (RE_Delay_Block), Loc))),
+ -- Generate:
+ -- procedure <temp>T is
+ -- begin
+ -- Tstmts
+ -- end <temp>T;
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
+ Tproc := SEU.Build_Wrapping_Procedure (Loc, 'T', Decls, Tstats);
- Analyze (N);
- return;
+ -- Generate:
+ -- _dispatching_get_prim_op_kind (<object>, S, C);
+
+ Append_To (Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ Make_Identifier (Loc, Name_uDisp_Get_Prim_Op_Kind),
+ Parameter_Associations =>
+ New_List (
+ New_Copy_Tree (Obj),
+ New_Reference_To (S, Loc),
+ New_Reference_To (C, Loc))));
+
+ -- Protected entry handling
+
+ -- Generate:
+ -- Param1 := P.Param1;
+ -- ...
+ -- ParamN := P.ParamN;
+
+ Cleanup_Stmts := Parameter_Block_Unpack (Loc, Actuals, Formals);
+
+ -- Generate:
+ -- _dispatching_asynchronous_select
+ -- (<object>, S, P'address, Bnn, B);
+
+ Prepend_To (Cleanup_Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ Make_Identifier (Loc, Name_uDisp_Asynchronous_Select),
+ Parameter_Associations =>
+ New_List (
+ New_Copy_Tree (Obj),
+ New_Reference_To (S, Loc),
+ P,
+ New_Reference_To (Bnn, Loc),
+ New_Reference_To (B, Loc))));
+
+ -- Generate:
+ -- if Enqueued (Bnn) then
+ -- <temp>A
+ -- end if;
+
+ -- where <temp>A is the abort statements wrapping procedure
+
+ Append_To (Cleanup_Stmts,
+ Make_If_Statement (Loc,
+ Condition =>
+ Make_Function_Call (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Enqueued), Loc),
+ Parameter_Associations =>
+ New_List (
+ New_Reference_To (Bnn, Loc))),
+
+ Then_Statements =>
+ New_List (
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (Aproc, Loc),
+ Parameter_Associations =>
+ No_List))));
+
+ -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions
+ -- will then generate a _clean for the communication block Bnn.
+
+ -- Generate:
+ -- declare
+ -- procedure _clean is
+ -- begin
+ -- if Enqueued (Bnn) then
+ -- Cancel_Protected_Entry_Call (Bnn);
+ -- end if;
+ -- end _clean;
+ -- begin
+ -- Cleanup_Stmts
+ -- at end
+ -- _clean;
+ -- end;
+
+ Cleanup_Block :=
+ SEU.Build_Cleanup_Block (Loc, Blk_Ent, Cleanup_Stmts, Bnn);
+
+ -- Wrap the cleanup block in an exception handling block.
+
+ -- Generate:
+ -- begin
+ -- Cleanup_Block
+ -- exception
+ -- when Abort_Signal => Abort_Undefer;
+ -- end;
+
+ ProtE_Stmts :=
+ New_List (
+ SEU.Build_Abort_Block (Loc, Blk_Ent, Cleanup_Block));
+
+ -- Generate:
+ -- if not Cancelled (Bnn) then
+ -- <temp>T
+ -- end if;
+
+ -- there <temp>T is the triggering statements wrapping procedure
+
+ Append_To (ProtE_Stmts,
+ Make_If_Statement (Loc,
+ Condition =>
+ Make_Op_Not (Loc,
+ Right_Opnd =>
+ Make_Function_Call (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Cancelled), Loc),
+ Parameter_Associations =>
+ New_List (
+ New_Reference_To (Bnn, Loc)))),
+
+ Then_Statements =>
+ New_List (
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (Tproc, Loc),
+ Parameter_Associations =>
+ No_List))));
+
+ -------------------------------------------------------------------
+ -- Task entry handling
+
+ -- Generate:
+ -- Param1 := P.Param1;
+ -- ...
+ -- ParamN := P.ParamN;
+
+ TaskE_Stmts := Parameter_Block_Unpack (Loc, Actuals, Formals);
+
+ -- Generate:
+ -- _dispatching_asynchronous_select
+ -- (<object>, S, P'address, Bnn, B);
+
+ Prepend_To (TaskE_Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ Make_Identifier (Loc, Name_uDisp_Asynchronous_Select),
+ Parameter_Associations =>
+ New_List (
+ New_Copy_Tree (Obj),
+ New_Reference_To (S, Loc),
+ New_Copy_Tree (P),
+ New_Reference_To (Bnn, Loc),
+ New_Reference_To (B, Loc))));
+
+ -- Generate:
+ -- Abort_Defer;
+
+ Prepend_To (TaskE_Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Abort_Defer), Loc),
+ Parameter_Associations =>
+ No_List));
+
+ -- Generate:
+ -- Abort_Undefer;
+ -- <temp>A
+
+ -- where <temp>A is the abortable statements wrapping procedure
+
+ Cleanup_Stmts :=
+ New_List (
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Abort_Undefer), Loc),
+ Parameter_Associations =>
+ No_List),
+
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (Aproc, Loc),
+ Parameter_Associations =>
+ No_List));
+
+ -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions
+ -- will generate a _clean for the additional status flag.
+
+ -- Generate:
+ -- declare
+ -- procedure _clean is
+ -- begin
+ -- Cancel_Task_Entry_Call (U);
+ -- end _clean;
+ -- begin
+ -- Cleanup_Stmts
+ -- at end
+ -- _clean;
+ -- end;
+
+ Blk_Ent := Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
+
+ Cleanup_Block :=
+ SEU.Build_Cleanup_Block (Loc, Blk_Ent, Cleanup_Stmts, U);
+
+ -- Wrap the cleanup block in an exception handling block
+
+ -- Generate:
+ -- begin
+ -- Cleanup_Block
+ -- exception
+ -- when Abort_Signal => Abort_Undefer;
+ -- end;
+
+ Append_To (TaskE_Stmts,
+ SEU.Build_Abort_Block (Loc, Blk_Ent, Cleanup_Block));
+
+ -- Generate:
+ -- if not U then
+ -- <temp>T
+ -- end if;
+
+ -- where <temp>T is the triggering statements wrapping procedure
+
+ Append_To (TaskE_Stmts,
+ Make_If_Statement (Loc,
+ Condition =>
+ Make_Op_Not (Loc,
+ Right_Opnd =>
+ New_Reference_To (U, Loc)),
+ Then_Statements =>
+ New_List (
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (Tproc, Loc),
+ Parameter_Associations =>
+ No_List))));
+
+ -------------------------------------------------------------------
+ -- Protected procedure handling
+
+ -- Generate:
+ -- <dispatching-call>;
+ -- <temp>T;
+
+ -- where <temp>T is the triggering statements wrapping procedure
+
+ ProtP_Stmts :=
+ New_List (
+ New_Copy_Tree (Ecall),
+
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (Tproc, Loc),
+ Parameter_Associations =>
+ No_List));
+
+ -- Generate:
+ -- if C = POK_Procedure_Entry then
+ -- ProtE_Stmts
+ -- elsif C = POK_Task_Entry then
+ -- TaskE_Stmts
+ -- else
+ -- ProtP_Stmts
+ -- end if;
+
+ Append_To (Stmts,
+ Make_If_Statement (Loc,
+ Condition =>
+ Make_Op_Eq (Loc,
+ Left_Opnd =>
+ New_Reference_To (C, Loc),
+ Right_Opnd =>
+ New_Reference_To (RTE (RE_POK_Protected_Entry), Loc)),
+
+ Then_Statements =>
+ ProtE_Stmts,
+
+ Elsif_Parts =>
+ New_List (
+ Make_Elsif_Part (Loc,
+ Condition =>
+ Make_Op_Eq (Loc,
+ Left_Opnd =>
+ New_Reference_To (C, Loc),
+ Right_Opnd =>
+ New_Reference_To (RTE (RE_POK_Task_Entry), Loc)),
+ Then_Statements =>
+ TaskE_Stmts)),
+
+ Else_Statements =>
+ ProtP_Stmts));
+
+ Rewrite (N,
+ Make_Block_Statement (Loc,
+ Declarations =>
+ Decls,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
+
+ Analyze (N);
+ return;
+
+ -- Delay triggering statement processing
+
+ else
+ -- Add a Delay_Block object to the parameter list of the delay
+ -- procedure to form the parameter list of the Wait entry call.
+
+ Dblock_Ent :=
+ Make_Defining_Identifier (Loc, New_Internal_Name ('D'));
+
+ Pdef := Entity (Name (Ecall));
+
+ if Is_RTE (Pdef, RO_CA_Delay_For) then
+ Enqueue_Call :=
+ New_Reference_To (RTE (RE_Enqueue_Duration), Loc);
+
+ elsif Is_RTE (Pdef, RO_CA_Delay_Until) then
+ Enqueue_Call :=
+ New_Reference_To (RTE (RE_Enqueue_Calendar), Loc);
+
+ else pragma Assert (Is_RTE (Pdef, RO_RT_Delay_Until));
+ Enqueue_Call := New_Reference_To (RTE (RE_Enqueue_RT), Loc);
+ end if;
+
+ Append_To (Parameter_Associations (Ecall),
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Dblock_Ent, Loc),
+ Attribute_Name => Name_Unchecked_Access));
+
+ -- Create the inner block to protect the abortable part
+
+ Hdle := New_List (
+ Make_Exception_Handler (Loc,
+ Exception_Choices =>
+ New_List (New_Reference_To (Stand.Abort_Signal, Loc)),
+ Statements => New_List (
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc)))));
+
+ Prepend_To (Astats,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc)));
+
+ Abortable_Block :=
+ Make_Block_Statement (Loc,
+ Identifier => New_Reference_To (Blk_Ent, Loc),
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Astats),
+ Has_Created_Identifier => True,
+ Is_Asynchronous_Call_Block => True);
+
+ -- Append call to if Enqueue (When, DB'Unchecked_Access) then
+
+ Rewrite (Ecall,
+ Make_Implicit_If_Statement (N,
+ Condition => Make_Function_Call (Loc,
+ Name => Enqueue_Call,
+ Parameter_Associations => Parameter_Associations (Ecall)),
+ Then_Statements =>
+ New_List (Make_Block_Statement (Loc,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (
+ Make_Implicit_Label_Declaration (Loc,
+ Defining_Identifier => Blk_Ent,
+ Label_Construct => Abortable_Block),
+ Abortable_Block),
+ Exception_Handlers => Hdle)))));
+
+ Stmts := New_List (Ecall);
+
+ -- Construct statement sequence for new block
+
+ Append_To (Stmts,
+ Make_Implicit_If_Statement (N,
+ Condition => Make_Function_Call (Loc,
+ Name => New_Reference_To (
+ RTE (RE_Timed_Out), Loc),
+ Parameter_Associations => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Dblock_Ent, Loc),
+ Attribute_Name => Name_Unchecked_Access))),
+ Then_Statements => Tstats));
+
+ -- The result is the new block
+ Set_Entry_Cancel_Parameter (Blk_Ent, Dblock_Ent);
+
+ Rewrite (N,
+ Make_Block_Statement (Loc,
+ Declarations => New_List (
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Dblock_Ent,
+ Aliased_Present => True,
+ Object_Definition => New_Reference_To (
+ RTE (RE_Delay_Block), Loc))),
+
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
+
+ Analyze (N);
+ return;
+ end if;
else
N_Orig := N;
end if;
Decl := First (Decls);
while Present (Decl)
- and then (Nkind (Decl) /= N_Object_Declaration
- or else not Is_RTE
- (Etype (Object_Definition (Decl)), RE_Communication_Block))
+ and then
+ (Nkind (Decl) /= N_Object_Declaration
+ or else not Is_RTE (Etype (Object_Definition (Decl)),
+ RE_Communication_Block))
loop
Next (Decl);
end loop;
pragma Assert (Present (Decl));
Cancel_Param := Defining_Identifier (Decl);
- -- Change the mode of the Protected_Entry_Call call.
+ -- Change the mode of the Protected_Entry_Call call
+
-- Protected_Entry_Call (
-- Object => po._object'Access,
-- E => <entry index>;
Stmt := First (Stmts);
- -- Skip assignments to temporaries created for in-out parameters.
+ -- Skip assignments to temporaries created for in-out parameters
+
-- This makes unwarranted assumptions about the shape of the expanded
-- tree for the call, and should be cleaned up ???
Call := Stmt;
- Parm := First (Parameter_Associations (Call));
- while Present (Parm)
- and then not Is_RTE (Etype (Parm), RE_Call_Modes)
+ Param := First (Parameter_Associations (Call));
+ while Present (Param)
+ and then not Is_RTE (Etype (Param), RE_Call_Modes)
loop
- Next (Parm);
+ Next (Param);
end loop;
- pragma Assert (Present (Parm));
- Rewrite (Parm, New_Reference_To (RTE (RE_Asynchronous_Call), Loc));
- Analyze (Parm);
+ pragma Assert (Present (Param));
+ Rewrite (Param, New_Reference_To (RTE (RE_Asynchronous_Call), Loc));
+ Analyze (Param);
- -- Append an if statement to execute the abortable part.
- -- if Enqueued (Bnn) then
+ -- Append an if statement to execute the abortable part
+
+ -- Generate:
+ -- if Enqueued (Bnn) then
Append_To (Stmts,
Make_Implicit_If_Statement (N,
Abortable_Block :=
Make_Block_Statement (Loc,
- Identifier => New_Reference_To (Blkent, Loc),
+ Identifier => New_Reference_To (Blk_Ent, Loc),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stmts),
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Implicit_Label_Declaration (Loc,
- Defining_Identifier => Blkent,
+ Defining_Identifier => Blk_Ent,
Label_Construct => Abortable_Block),
Abortable_Block),
Abortable_Block :=
Make_Block_Statement (Loc,
- Identifier => New_Reference_To (Blkent, Loc),
+ Identifier => New_Reference_To (Blk_Ent, Loc),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Astats),
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Implicit_Label_Declaration (Loc,
- Defining_Identifier => Blkent,
+ Defining_Identifier => Blk_Ent,
Label_Construct => Abortable_Block),
Abortable_Block),
Exception_Handlers => Hdle)));
-- Create new call statement
- Parms := Parameter_Associations (Call);
- Append_To (Parms, New_Reference_To (RTE (RE_Asynchronous_Call), Loc));
- Append_To (Parms, New_Reference_To (B, Loc));
+ Params := Parameter_Associations (Call);
+
+ Append_To (Params,
+ New_Reference_To (RTE (RE_Asynchronous_Call), Loc));
+ Append_To (Params,
+ New_Reference_To (B, Loc));
+
Rewrite (Call,
Make_Procedure_Call_Statement (Loc,
- Name => New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
- Parameter_Associations => Parms));
+ Name =>
+ New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
+ Parameter_Associations => Params));
-- Construct statement sequence for new block
Append_To (Stmts,
Make_Implicit_If_Statement (N,
- Condition => Make_Op_Not (Loc,
- New_Reference_To (Cancel_Param, Loc)),
+ Condition =>
+ Make_Op_Not (Loc,
+ New_Reference_To (Cancel_Param, Loc)),
Then_Statements => Tstats));
-- Protected the call against abort
Parameter_Associations => Empty_List));
end if;
- Set_Entry_Cancel_Parameter (Blkent, Cancel_Param);
+ Set_Entry_Cancel_Parameter (Blk_Ent, Cancel_Param);
-- The result is the new block
-- ...
-- end;
+ -- Ada 2005 (AI-345): A dispatching conditional entry call is converted
+ -- into:
+
+ -- declare
+ -- B : Boolean := False;
+ -- C : Ada.Tags.Prim_Op_Kind;
+ -- P : Parameters := (Param1 .. ParamN);
+ -- S : constant Integer := DT_Position (<dispatching-procedure>);
+
+ -- begin
+ -- disp_conditional_select (<object>, S, P'address, C, B);
+
+ -- if C = POK_Protected_Entry
+ -- or else C = POK_Task_Entry
+ -- then
+ -- Param1 := P.Param1;
+ -- ...
+ -- ParamN := P.ParamN;
+ -- end if;
+
+ -- if B then
+ -- if C = POK_Procedure
+ -- or else C = POK_Protected_Procedure
+ -- or else C = POK_Task_Procedure
+ -- then
+ -- <dispatching-procedure> (<object>, Param1 .. ParamN);
+ -- end if;
+ -- <normal-statements>
+ -- else
+ -- <else-statements>
+ -- end if;
+ -- end;
+
procedure Expand_N_Conditional_Entry_Call (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Alt : constant Node_Id := Entry_Call_Alternative (N);
Blk : Node_Id := Entry_Call_Statement (Alt);
Transient_Blk : Node_Id;
- Parms : List_Id;
- Parm : Node_Id;
- Call : Node_Id;
- Stmts : List_Id;
- B : Entity_Id;
- Decl : Node_Id;
- Stmt : Node_Id;
+ Actuals : List_Id;
+ Blk_Typ : Entity_Id;
+ Call : Node_Id;
+ Call_Ent : Entity_Id;
+ Decl : Node_Id;
+ Decls : List_Id;
+ Formals : List_Id;
+ N_Stats : List_Id;
+ Obj : Entity_Id;
+ Param : Node_Id;
+ Params : List_Id;
+ Stmt : Node_Id;
+ Stmts : List_Id;
+
+ B : Entity_Id; -- Call status flag
+ C : Entity_Id; -- Call kind
+ P : Node_Id; -- Parameter block
+ S : Entity_Id; -- Primitive operation slot
begin
+ if Ada_Version >= Ada_05
+ and then Nkind (Blk) = N_Procedure_Call_Statement
+ then
+ Extract_Dispatching_Call (Blk, Call_Ent, Obj, Actuals, Formals);
+
+ Decls := New_List;
+ Stmts := New_List;
+
+ -- Call status flag processing, generate:
+ -- B : Boolean := False;
+
+ B := SEU.Build_B (Loc, Decls);
+
+ -- Call kind processing, generate:
+ -- C : Ada.Tags.Prim_Op_Kind;
+
+ C := SEU.Build_C (Loc, Decls);
+
+ -- Parameter block processing
+
+ Blk_Typ := Build_Parameter_Block (Loc, Actuals, Formals, Decls);
+ P := Parameter_Block_Pack (Loc, Blk_Typ, Actuals, Formals,
+ Decls, Stmts);
+
+ -- Dispatch table slot processing, generate:
+ -- S : constant Integer :=
+ -- DT_Position (<dispatching-procedure>);
+
+ S := SEU.Build_S (Loc, Decls, Call_Ent);
+
+ -- Generate:
+ -- _dispatching_conditional_select (<object>, S, P'address, C, B);
+
+ Append_To (Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ Make_Identifier (Loc, Name_uDisp_Conditional_Select),
+ Parameter_Associations =>
+ New_List (
+ New_Copy_Tree (Obj),
+ New_Reference_To (S, Loc),
+ P,
+ New_Reference_To (C, Loc),
+ New_Reference_To (B, Loc))));
+
+ -- Generate:
+ -- if C = POK_Protected_Entry
+ -- or else C = POK_Task_Entry
+ -- then
+ -- Param1 := P.Param1;
+ -- ...
+ -- ParamN := P.ParamN;
+ -- end if;
+
+ Append_To (Stmts,
+ Make_If_Statement (Loc,
+
+ Condition =>
+ Make_Or_Else (Loc,
+ Left_Opnd =>
+ Make_Op_Eq (Loc,
+ Left_Opnd =>
+ New_Reference_To (C, Loc),
+ Right_Opnd =>
+ New_Reference_To (RTE (RE_POK_Protected_Entry), Loc)),
+ Right_Opnd =>
+ Make_Op_Eq (Loc,
+ Left_Opnd =>
+ New_Reference_To (C, Loc),
+ Right_Opnd =>
+ New_Reference_To (RTE (RE_POK_Task_Entry), Loc))),
+
+ Then_Statements =>
+ Parameter_Block_Unpack (Loc, Actuals, Formals)));
+
+ -- Generate:
+ -- if B then
+ -- if C = POK_Procedure
+ -- or else C = POK_Protected_Procedure
+ -- or else C = POK_Task_Procedure
+ -- then
+ -- <dispatching-procedure-call>
+ -- end if;
+ -- <normal-statements>
+ -- else
+ -- <else-statements>
+ -- end if;
+
+ N_Stats := New_Copy_List (Statements (Alt));
+
+ Prepend_To (N_Stats,
+ Make_If_Statement (Loc,
+ Condition =>
+ Make_Or_Else (Loc,
+ Left_Opnd =>
+ Make_Op_Eq (Loc,
+ Left_Opnd =>
+ New_Reference_To (C, Loc),
+ Right_Opnd =>
+ New_Reference_To (RTE (RE_POK_Procedure), Loc)),
+
+ Right_Opnd =>
+ Make_Or_Else (Loc,
+ Left_Opnd =>
+ Make_Op_Eq (Loc,
+ Left_Opnd =>
+ New_Reference_To (C, Loc),
+ Right_Opnd =>
+ New_Reference_To (RTE (
+ RE_POK_Protected_Procedure), Loc)),
+
+ Right_Opnd =>
+ Make_Op_Eq (Loc,
+ Left_Opnd =>
+ New_Reference_To (C, Loc),
+ Right_Opnd =>
+ New_Reference_To (RTE (
+ RE_POK_Task_Procedure), Loc)))),
+
+ Then_Statements =>
+ New_List (Blk)));
+
+ Append_To (Stmts,
+ Make_If_Statement (Loc,
+ Condition => New_Reference_To (B, Loc),
+ Then_Statements => N_Stats,
+ Else_Statements => Else_Statements (N)));
+
+ Rewrite (N,
+ Make_Block_Statement (Loc,
+ Declarations => Decls,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
+
-- As described above, The entry alternative is transformed into a
-- block that contains the gnulli call, and possibly assignment
-- statements for in-out parameters. The gnulli call may itself be
-- require it. We need to retrieve the call to complete its parameter
-- list.
- Transient_Blk :=
- First_Real_Statement (Handled_Statement_Sequence (Blk));
-
- if Present (Transient_Blk)
- and then
- Nkind (Transient_Blk) = N_Block_Statement
- then
- Blk := Transient_Blk;
- end if;
-
- Stmts := Statements (Handled_Statement_Sequence (Blk));
+ else
+ Transient_Blk :=
+ First_Real_Statement (Handled_Statement_Sequence (Blk));
- Stmt := First (Stmts);
+ if Present (Transient_Blk)
+ and then Nkind (Transient_Blk) = N_Block_Statement
+ then
+ Blk := Transient_Blk;
+ end if;
- while Nkind (Stmt) /= N_Procedure_Call_Statement loop
- Next (Stmt);
- end loop;
+ Stmts := Statements (Handled_Statement_Sequence (Blk));
+ Stmt := First (Stmts);
+ while Nkind (Stmt) /= N_Procedure_Call_Statement loop
+ Next (Stmt);
+ end loop;
- Call := Stmt;
+ Call := Stmt;
+ Params := Parameter_Associations (Call);
- Parms := Parameter_Associations (Call);
+ if Is_RTE (Entity (Name (Call)), RE_Protected_Entry_Call) then
- if Is_RTE (Entity (Name (Call)), RE_Protected_Entry_Call) then
+ -- Substitute Conditional_Entry_Call for Simple_Call parameter
- -- Substitute Conditional_Entry_Call for Simple_Call
- -- parameter.
+ Param := First (Params);
+ while Present (Param)
+ and then not Is_RTE (Etype (Param), RE_Call_Modes)
+ loop
+ Next (Param);
+ end loop;
- Parm := First (Parms);
- while Present (Parm)
- and then not Is_RTE (Etype (Parm), RE_Call_Modes)
- loop
- Next (Parm);
- end loop;
+ pragma Assert (Present (Param));
+ Rewrite (Param, New_Reference_To (RTE (RE_Conditional_Call), Loc));
- pragma Assert (Present (Parm));
- Rewrite (Parm, New_Reference_To (RTE (RE_Conditional_Call), Loc));
+ Analyze (Param);
- Analyze (Parm);
+ -- Find the Communication_Block parameter for the call to the
+ -- Cancelled function.
- -- Find the Communication_Block parameter for the call
- -- to the Cancelled function.
+ Decl := First (Declarations (Blk));
+ while Present (Decl)
+ and then not Is_RTE (Etype (Object_Definition (Decl)),
+ RE_Communication_Block)
+ loop
+ Next (Decl);
+ end loop;
- Decl := First (Declarations (Blk));
- while Present (Decl)
- and then not
- Is_RTE (Etype (Object_Definition (Decl)), RE_Communication_Block)
- loop
- Next (Decl);
- end loop;
+ -- Add an if statement to execute the else part if the call
+ -- does not succeed (as indicated by the Cancelled predicate).
- -- Add an if statement to execute the else part if the call
- -- does not succeed (as indicated by the Cancelled predicate).
+ Append_To (Stmts,
+ Make_Implicit_If_Statement (N,
+ Condition => Make_Function_Call (Loc,
+ Name => New_Reference_To (RTE (RE_Cancelled), Loc),
+ Parameter_Associations => New_List (
+ New_Reference_To (Defining_Identifier (Decl), Loc))),
+ Then_Statements => Else_Statements (N),
+ Else_Statements => Statements (Alt)));
- Append_To (Stmts,
- Make_Implicit_If_Statement (N,
- Condition => Make_Function_Call (Loc,
- Name => New_Reference_To (RTE (RE_Cancelled), Loc),
- Parameter_Associations => New_List (
- New_Reference_To (Defining_Identifier (Decl), Loc))),
- Then_Statements => Else_Statements (N),
- Else_Statements => Statements (Alt)));
+ else
+ B := Make_Defining_Identifier (Loc, Name_uB);
- else
- B := Make_Defining_Identifier (Loc, Name_uB);
+ -- Insert declaration of B in declarations of existing block
- -- Insert declaration of B in declarations of existing block
+ if No (Declarations (Blk)) then
+ Set_Declarations (Blk, New_List);
+ end if;
- if No (Declarations (Blk)) then
- Set_Declarations (Blk, New_List);
- end if;
+ Prepend_To (Declarations (Blk),
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => B,
+ Object_Definition =>
+ New_Reference_To (Standard_Boolean, Loc)));
- Prepend_To (Declarations (Blk),
- Make_Object_Declaration (Loc,
- Defining_Identifier => B,
- Object_Definition => New_Reference_To (Standard_Boolean, Loc)));
+ -- Create new call statement
- -- Create new call statement
+ Append_To (Params,
+ New_Reference_To (RTE (RE_Conditional_Call), Loc));
+ Append_To (Params, New_Reference_To (B, Loc));
- Append_To (Parms, New_Reference_To (RTE (RE_Conditional_Call), Loc));
- Append_To (Parms, New_Reference_To (B, Loc));
+ Rewrite (Call,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
+ Parameter_Associations => Params));
- Rewrite (Call,
- Make_Procedure_Call_Statement (Loc,
- Name => New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
- Parameter_Associations => Parms));
+ -- Construct statement sequence for new block
- -- Construct statement sequence for new block
+ Append_To (Stmts,
+ Make_Implicit_If_Statement (N,
+ Condition => New_Reference_To (B, Loc),
+ Then_Statements => Statements (Alt),
+ Else_Statements => Else_Statements (N)));
+ end if;
- Append_To (Stmts,
- Make_Implicit_If_Statement (N,
- Condition => New_Reference_To (B, Loc),
- Then_Statements => Statements (Alt),
- Else_Statements => Else_Statements (N)));
+ -- The result is the new block
+ Rewrite (N,
+ Make_Block_Statement (Loc,
+ Declarations => Declarations (Blk),
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
end if;
- -- The result is the new block
-
- Rewrite (N,
- Make_Block_Statement (Loc,
- Declarations => Declarations (Blk),
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
-
Analyze (N);
end Expand_N_Conditional_Entry_Call;
procedure Expand_N_Delay_Relative_Statement (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
-
begin
Rewrite (N,
Make_Procedure_Call_Statement (Loc,
-- <sequence of statements>
-- end pprocN;
- -- procedure pproc (_object : in out poV;...) is
+ -- procedure pprocP (_object : in out poV;...) is
-- procedure _clean is
-- Pn : Boolean;
-- begin
-- <sequence of statements>
-- end pfuncN;
- -- function pfunc (_object : poV) return Return_Type is
+ -- function pfuncP (_object : poV) return Return_Type is
-- procedure _clean is
-- begin
-- Unlock (_object._object'Access);
Op_Decl : Node_Id;
Op_Body : Node_Id;
Op_Id : Entity_Id;
+ Disp_Op_Body : Node_Id;
New_Op_Body : Node_Id;
Current_Node : Node_Id;
Num_Entries : Natural := 0;
+ function Build_Dispatching_Subprogram_Body
+ (N : Node_Id;
+ Pid : Node_Id;
+ Prot_Bod : Node_Id) return Node_Id;
+ -- Build a dispatching version of the protected subprogram body. The
+ -- newly generated subprogram contains a call to the original protected
+ -- body. The following code is generated:
+ --
+ -- function <protected-function-name> (Param1 .. ParamN) return
+ -- <return-type> is
+ -- begin
+ -- return <protected-function-name>P (Param1 .. ParamN);
+ -- end <protected-function-name>;
+ --
+ -- or
+ --
+ -- procedure <protected-procedure-name> (Param1 .. ParamN) is
+ -- begin
+ -- <protected-procedure-name>P (Param1 .. ParamN);
+ -- end <protected-procedure-name>
+
+ ---------------------------------------
+ -- Build_Dispatching_Subprogram_Body --
+ ---------------------------------------
+
+ function Build_Dispatching_Subprogram_Body
+ (N : Node_Id;
+ Pid : Node_Id;
+ Prot_Bod : Node_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+ Actuals : List_Id;
+ Formal : Node_Id;
+ Spec : Node_Id;
+ Stmts : List_Id;
+
+ begin
+ -- Generate a specification without a letter suffix in order to
+ -- override an interface function or procedure.
+
+ Spec :=
+ Build_Protected_Sub_Specification (N, Pid, Dispatching_Mode);
+
+ -- The formal parameters become the actuals of the protected
+ -- function or procedure call.
+
+ Actuals := New_List;
+ Formal := First (Parameter_Specifications (Spec));
+
+ while Present (Formal) loop
+ Append_To (Actuals,
+ Make_Identifier (Loc, Chars (Defining_Identifier (Formal))));
+
+ Next (Formal);
+ end loop;
+
+ if Nkind (Spec) = N_Procedure_Specification then
+ Stmts :=
+ New_List (
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (Corresponding_Spec (Prot_Bod), Loc),
+ Parameter_Associations => Actuals));
+ else
+ pragma Assert (Nkind (Spec) = N_Function_Specification);
+
+ Stmts :=
+ New_List (
+ Make_Return_Statement (Loc,
+ Expression =>
+ Make_Function_Call (Loc,
+ Name =>
+ New_Reference_To (Corresponding_Spec (Prot_Bod), Loc),
+ Parameter_Associations => Actuals)));
+ end if;
+
+ return
+ Make_Subprogram_Body (Loc,
+ Declarations => Empty_List,
+ Specification => Spec,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc, Stmts));
+ end Build_Dispatching_Subprogram_Body;
+
+ -- Start of processing for Expand_N_Protected_Body
+
begin
if No_Run_Time_Mode then
Error_Msg_CRT ("protected body", N);
Insert_After (Current_Node, New_Op_Body);
Analyze (New_Op_Body);
+
+ Current_Node := New_Op_Body;
+
+ -- Generate an overriding primitive operation body for
+ -- this subprogram if the protected type implements
+ -- an inerface.
+
+ if Ada_Version >= Ada_05
+ and then Present (Abstract_Interfaces (
+ Corresponding_Record_Type (Pid)))
+ then
+ Disp_Op_Body :=
+ Build_Dispatching_Subprogram_Body (
+ Op_Body, Pid, New_Op_Body);
+
+ Insert_After (Current_Node, Disp_Op_Body);
+ Analyze (Disp_Op_Body);
+
+ Current_Node := Disp_Op_Body;
+ end if;
end if;
end if;
end if;
Sloc => Loc,
Constraints => New_List (Entry_Count_Expr)));
- elsif Has_Entries (Prottyp) then
+ -- The type has explicit entries or generated primitive entry
+ -- wrappers.
+
+ elsif Has_Entries (Prottyp)
+ or else (Ada_Version >= Ada_05
+ and then Present (Interface_List (N)))
+ then
if Abort_Allowed
or else Restriction_Active (No_Entry_Queue) = False
or else Number_Entries (Prottyp) > 1
Make_Subprogram_Declaration (Loc,
Specification =>
Build_Protected_Sub_Specification
- (Priv, Prottyp, Unprotected => True));
+ (Priv, Prottyp, Unprotected_Mode));
Insert_After (Current_Node, Sub);
Analyze (Sub);
Defining_Unit_Name (Specification (Sub)));
Current_Node := Sub;
+
if Is_Interrupt_Handler
(Defining_Unit_Name (Specification (Priv)))
then
Make_Subprogram_Declaration (Loc,
Specification =>
Build_Protected_Sub_Specification
- (Priv, Prottyp, Unprotected => False));
+ (Priv, Prottyp, Protected_Mode));
Insert_After (Current_Node, Sub);
Analyze (Sub);
Make_Subprogram_Declaration (Loc,
Specification =>
Build_Protected_Sub_Specification
- (Comp, Prottyp, Unprotected => True));
+ (Comp, Prottyp, Unprotected_Mode));
Insert_After (Current_Node, Sub);
Analyze (Sub);
Make_Subprogram_Declaration (Loc,
Specification =>
Build_Protected_Sub_Specification
- (Comp, Prottyp, Unprotected => False));
+ (Comp, Prottyp, Protected_Mode));
Insert_After (Current_Node, Sub);
Analyze (Sub);
+
Current_Node := Sub;
+ -- Generate an overriding primitive operation specification for
+ -- this subprogram if the protected type implements an inerface.
+
+ if Ada_Version >= Ada_05
+ and then
+ Present (Abstract_Interfaces
+ (Corresponding_Record_Type (Prottyp)))
+ then
+ Sub :=
+ Make_Subprogram_Declaration (Loc,
+ Specification =>
+ Build_Protected_Sub_Specification
+ (Comp, Prottyp, Dispatching_Mode));
+
+ Insert_After (Current_Node, Sub);
+ Analyze (Sub);
+
+ Current_Node := Sub;
+ end if;
+
-- If a pragma Interrupt_Handler applies, build and add
-- a call to Register_Interrupt_Handler to the freezing actions
-- of the protected version (Current_Node) of the subprogram:
if not Restricted_Profile
and then Is_Interrupt_Handler
- (Defining_Unit_Name (Specification (Comp)))
+ (Defining_Unit_Name (Specification (Comp)))
then
Register_Handler;
end if;
if Present (Private_Declarations (Pdef)) then
Comp := First (Private_Declarations (Pdef));
-
while Present (Comp) loop
if Nkind (Comp) = N_Entry_Declaration then
E_Count := E_Count + 1;
-- 1) When T.E is a task entry_call;
-- declare
- -- B : Boolean;
- -- X : Task_Entry_Index := <entry index>;
+ -- B : Boolean;
+ -- X : Task_Entry_Index := <entry index>;
-- DX : Duration := To_Duration (D);
- -- M : Delay_Mode := <discriminant>;
- -- P : parms := (parm, parm, parm);
+ -- M : Delay_Mode := <discriminant>;
+ -- P : parms := (parm, parm, parm);
-- begin
-- Timed_Protected_Entry_Call (<acceptor-task>, X, P'Address,
-- B : Boolean;
-- X : Protected_Entry_Index := <entry index>;
-- DX : Duration := To_Duration (D);
- -- M : Delay_Mode := <discriminant>;
+ -- M : Delay_Mode := <discriminant>;
-- P : parms := (parm, parm, parm);
-- begin
-- end if;
-- end;
+ -- 3) Ada 2005 (AI-345): When T.E is a dispatching procedure call;
+
+ -- declare
+ -- B : Boolean := False;
+ -- C : Ada.Tags.Prim_Op_Kind;
+ -- DX : Duration := To_Duration (D)
+ -- M : Integer :=...;
+ -- P : Parameters := (Param1 .. ParamN);
+ -- S : constant Iteger := DT_Position (<dispatching-procedure>);
+
+ -- begin
+ -- disp_timed_select (<object>, S, P'Address, DX, M, C, B);
+
+ -- if C = POK_Protected_Entry
+ -- or else C = POK_Task_Entry
+ -- then
+ -- Param1 := P.Param1;
+ -- ...
+ -- ParamN := P.ParamN;
+ -- end if;
+
+ -- if B then
+ -- if C = POK_Procedure
+ -- or else C = POK_Protected_Procedure
+ -- or else C = POK_Task_Procedure
+ -- then
+ -- T.E;
+ -- end if;
+ -- S1;
+ -- else
+ -- S2;
+ -- end if;
+ -- end;
+
procedure Expand_N_Timed_Entry_Call (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
D_Stats : constant List_Id :=
Statements (Delay_Alternative (N));
- Stmts : List_Id;
- Stmt : Node_Id;
- Parms : List_Id;
- Parm : Node_Id;
-
- Concval : Node_Id;
- Ename : Node_Id;
- Index : Node_Id;
-
- Decls : List_Id;
- Disc : Node_Id;
- Conv : Node_Id;
- B : Entity_Id;
- D : Entity_Id;
- Dtyp : Entity_Id;
- M : Entity_Id;
-
- Call : Node_Id;
- Dummy : Node_Id;
+ Actuals : List_Id;
+ Blk_Typ : Entity_Id;
+ Call : Node_Id;
+ Call_Ent : Entity_Id;
+ Concval : Node_Id;
+ D_Conv : Node_Id;
+ D_Disc : Node_Id;
+ D_Type : Entity_Id;
+ Decls : List_Id;
+ Dummy : Node_Id;
+ Ename : Node_Id;
+ Formals : List_Id;
+ Index : Node_Id;
+ N_Stats : List_Id;
+ Obj : Entity_Id;
+ Param : Node_Id;
+ Params : List_Id;
+ Stmt : Node_Id;
+ Stmts : List_Id;
+
+ B : Entity_Id; -- Call status flag
+ C : Entity_Id; -- Call kind
+ D : Entity_Id; -- Delay
+ M : Entity_Id; -- Delay mode
+ P : Node_Id; -- Parameter block
+ S : Entity_Id; -- Primitive operation slot
begin
-- The arguments in the call may require dynamic allocation, and the
if Nkind (E_Call) = N_Block_Statement then
E_Call := First (Statements (Handled_Statement_Sequence (E_Call)));
-
while Nkind (E_Call) /= N_Procedure_Call_Statement
and then Nkind (E_Call) /= N_Entry_Call_Statement
loop
end loop;
end if;
- -- Build an entry call using Simple_Entry_Call. We will use this as the
- -- base for creating appropriate calls.
+ if Ada_Version >= Ada_05
+ and then Nkind (E_Call) = N_Procedure_Call_Statement
+ then
+ Extract_Dispatching_Call (E_Call, Call_Ent, Obj, Actuals, Formals);
+
+ Decls := New_List;
+ Stmts := New_List;
- Extract_Entry (E_Call, Concval, Ename, Index);
- Build_Simple_Entry_Call (E_Call, Concval, Ename, Index);
+ else
+ -- Build an entry call using Simple_Entry_Call
- Stmts := Statements (Handled_Statement_Sequence (E_Call));
- Decls := Declarations (E_Call);
+ Extract_Entry (E_Call, Concval, Ename, Index);
+ Build_Simple_Entry_Call (E_Call, Concval, Ename, Index);
- if No (Decls) then
- Decls := New_List;
+ Decls := Declarations (E_Call);
+ Stmts := Statements (Handled_Statement_Sequence (E_Call));
+
+ if No (Decls) then
+ Decls := New_List;
+ end if;
end if;
- Dtyp := Base_Type (Etype (Expression (D_Stat)));
+ -- Call status flag processing
+
+ if Ada_Version >= Ada_05
+ and then Nkind (E_Call) = N_Procedure_Call_Statement
+ then
+ -- Generate:
+ -- B : Boolean := False;
+
+ B := SEU.Build_B (Loc, Decls);
+
+ else
+ -- Generate:
+ -- B : Boolean;
+
+ B := Make_Defining_Identifier (Loc, Name_uB);
+
+ Prepend_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ B,
+ Object_Definition =>
+ New_Reference_To (Standard_Boolean, Loc)));
+ end if;
+
+ -- Call kind processing
+
+ if Ada_Version >= Ada_05
+ and then Nkind (E_Call) = N_Procedure_Call_Statement
+ then
+ -- Generate:
+ -- C : Ada.Tags.Prim_Op_Kind;
+
+ C := SEU.Build_C (Loc, Decls);
+ end if;
+
+ -- Duration and mode processing
+
+ D_Type := Base_Type (Etype (Expression (D_Stat)));
-- Use the type of the delay expression (Calendar or Real_Time)
-- to generate the appropriate conversion.
if Nkind (D_Stat) = N_Delay_Relative_Statement then
- Disc := Make_Integer_Literal (Loc, 0);
- Conv := Relocate_Node (Expression (D_Stat));
+ D_Disc := Make_Integer_Literal (Loc, 0);
+ D_Conv := Relocate_Node (Expression (D_Stat));
- elsif Is_RTE (Dtyp, RO_CA_Time) then
- Disc := Make_Integer_Literal (Loc, 1);
- Conv := Make_Function_Call (Loc,
+ elsif Is_RTE (D_Type, RO_CA_Time) then
+ D_Disc := Make_Integer_Literal (Loc, 1);
+ D_Conv := Make_Function_Call (Loc,
New_Reference_To (RTE (RO_CA_To_Duration), Loc),
New_List (New_Copy (Expression (D_Stat))));
- else pragma Assert (Is_RTE (Dtyp, RO_RT_Time));
- Disc := Make_Integer_Literal (Loc, 2);
- Conv := Make_Function_Call (Loc,
+ else pragma Assert (Is_RTE (D_Type, RO_RT_Time));
+ D_Disc := Make_Integer_Literal (Loc, 2);
+ D_Conv := Make_Function_Call (Loc,
New_Reference_To (RTE (RO_RT_To_Duration), Loc),
New_List (New_Copy (Expression (D_Stat))));
end if;
- -- Create Duration and Delay_Mode objects for passing a delay value
-
D := Make_Defining_Identifier (Loc, New_Internal_Name ('D'));
- M := Make_Defining_Identifier (Loc, New_Internal_Name ('M'));
- Append_To (Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier => D,
- Object_Definition => New_Reference_To (Standard_Duration, Loc)));
+ -- Generate:
+ -- D : Duration;
Append_To (Decls,
Make_Object_Declaration (Loc,
- Defining_Identifier => M,
- Object_Definition => New_Reference_To (Standard_Integer, Loc),
- Expression => Disc));
+ Defining_Identifier =>
+ D,
+ Object_Definition =>
+ New_Reference_To (Standard_Duration, Loc)));
- B := Make_Defining_Identifier (Loc, Name_uB);
+ M := Make_Defining_Identifier (Loc, New_Internal_Name ('M'));
- -- Create a boolean object used for a return parameter
+ -- Generate:
+ -- M : Integer := (0 | 1 | 2);
- Prepend_To (Decls,
+ Append_To (Decls,
Make_Object_Declaration (Loc,
- Defining_Identifier => B,
- Object_Definition => New_Reference_To (Standard_Boolean, Loc)));
-
- Stmt := First (Stmts);
-
- -- Skip assignments to temporaries created for in-out parameters.
- -- This makes unwarranted assumptions about the shape of the expanded
- -- tree for the call, and should be cleaned up ???
-
- while Nkind (Stmt) /= N_Procedure_Call_Statement loop
- Next (Stmt);
- end loop;
+ Defining_Identifier =>
+ M,
+ Object_Definition =>
+ New_Reference_To (Standard_Integer, Loc),
+ Expression =>
+ D_Disc));
-- Do the assignement at this stage only because the evaluation of the
-- expression must not occur before (see ACVC C97302A).
- Insert_Before (Stmt,
+ Append_To (Stmts,
Make_Assignment_Statement (Loc,
- Name => New_Reference_To (D, Loc),
- Expression => Conv));
+ Name =>
+ New_Reference_To (D, Loc),
+ Expression =>
+ D_Conv));
- Call := Stmt;
+ -- Parameter block processing
- Parms := Parameter_Associations (Call);
+ -- Manually create the parameter block for dispatching calls. In the
+ -- case of entries, the block has already been created during the call
+ -- to Build_Simple_Entry_Call.
- -- For a protected type, we build a Timed_Protected_Entry_Call
+ if Ada_Version >= Ada_05
+ and then Nkind (E_Call) = N_Procedure_Call_Statement
+ then
+ Blk_Typ := Build_Parameter_Block (Loc, Actuals, Formals, Decls);
+ P := Parameter_Block_Pack (Loc, Blk_Typ, Actuals, Formals,
+ Decls, Stmts);
- if Is_Protected_Type (Etype (Concval)) then
+ -- Dispatch table slot processing, generate:
+ -- S : constant Integer :=
+ -- DT_Prosition (<dispatching-procedure>)
- -- Create a new call statement
+ S := SEU.Build_S (Loc, Decls, Call_Ent);
- Parm := First (Parms);
+ -- Generate:
+ -- _dispatching_timed_select (Obj, S, P'address, D, M, C, B);
- while Present (Parm)
- and then not Is_RTE (Etype (Parm), RE_Call_Modes)
- loop
- Next (Parm);
- end loop;
+ -- where Obj is the controlling formal parameter, S is the dispatch
+ -- table slot number of the dispatching operation, P is the wrapped
+ -- parameter block, D is the duration, M is the duration mode, C is
+ -- the call kind and B is the call status.
- Dummy := Remove_Next (Next (Parm));
+ Params := New_List;
- -- Remove garbage is following the Cancel_Param if present
+ Append_To (Params, New_Copy_Tree (Obj));
+ Append_To (Params, New_Reference_To (S, Loc));
+ Append_To (Params, P);
+ Append_To (Params, New_Reference_To (D, Loc));
+ Append_To (Params, New_Reference_To (M, Loc));
+ Append_To (Params, New_Reference_To (C, Loc));
+ Append_To (Params, New_Reference_To (B, Loc));
- Dummy := Next (Parm);
+ Append_To (Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ Make_Identifier (Loc, Name_uDisp_Timed_Select),
+ Parameter_Associations =>
+ Params));
+
+ -- Generate:
+ -- if C = POK_Protected_Entry
+ -- or else C = POK_Task_Entry
+ -- then
+ -- Param1 := P.Param1;
+ -- ...
+ -- ParamN := P.ParamN;
+ -- end if;
- -- Remove the mode of the Protected_Entry_Call call, then remove the
- -- Communication_Block of the Protected_Entry_Call call, and finally
- -- add Duration and a Delay_Mode parameter
+ Append_To (Stmts,
+ Make_If_Statement (Loc,
+
+ Condition =>
+ Make_Or_Else (Loc,
+ Left_Opnd =>
+ Make_Op_Eq (Loc,
+ Left_Opnd =>
+ New_Reference_To (C, Loc),
+ Right_Opnd =>
+ New_Reference_To (RTE (RE_POK_Protected_Entry), Loc)),
+ Right_Opnd =>
+ Make_Op_Eq (Loc,
+ Left_Opnd =>
+ New_Reference_To (C, Loc),
+ Right_Opnd =>
+ New_Reference_To (RTE (RE_POK_Task_Entry), Loc))),
- pragma Assert (Present (Parm));
- Rewrite (Parm, New_Reference_To (D, Loc));
+ Then_Statements =>
+ Parameter_Block_Unpack (Loc, Actuals, Formals)));
+
+ -- Generate:
+ -- if B then
+ -- if C = POK_Procedure
+ -- or else C = POK_Protected_Procedure
+ -- or else C = POK_Task_Procedure
+ -- then
+ -- <dispatching-procedure-call>
+ -- end if;
+ -- <normal-statements>
+ -- else
+ -- <delay-statements>
+ -- end if;
- Rewrite (Dummy, New_Reference_To (M, Loc));
+ N_Stats := New_Copy_List (E_Stats);
+
+ Prepend_To (N_Stats,
+ Make_If_Statement (Loc,
+
+ Condition =>
+ Make_Or_Else (Loc,
+ Left_Opnd =>
+ Make_Op_Eq (Loc,
+ Left_Opnd =>
+ New_Reference_To (C, Loc),
+ Right_Opnd =>
+ New_Reference_To (RTE (RE_POK_Procedure), Loc)),
+ Right_Opnd =>
+ Make_Or_Else (Loc,
+ Left_Opnd =>
+ Make_Op_Eq (Loc,
+ Left_Opnd =>
+ New_Reference_To (C, Loc),
+ Right_Opnd =>
+ New_Reference_To (RTE (
+ RE_POK_Protected_Procedure), Loc)),
+ Right_Opnd =>
+ Make_Op_Eq (Loc,
+ Left_Opnd =>
+ New_Reference_To (C, Loc),
+ Right_Opnd =>
+ New_Reference_To (RTE (
+ RE_POK_Task_Procedure), Loc)))),
- -- Add a Boolean flag for successful entry call
+ Then_Statements =>
+ New_List (E_Call)));
- Append_To (Parms, New_Reference_To (B, Loc));
+ Append_To (Stmts,
+ Make_If_Statement (Loc,
+ Condition => New_Reference_To (B, Loc),
+ Then_Statements => N_Stats,
+ Else_Statements => D_Stats));
+ else
+ -- Skip assignments to temporaries created for in-out parameters.
+ -- This makes unwarranted assumptions about the shape of the expanded
+ -- tree for the call, and should be cleaned up ???
- if Abort_Allowed
- or else Restriction_Active (No_Entry_Queue) = False
- or else Number_Entries (Etype (Concval)) > 1
- then
- Rewrite (Call,
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Reference_To (RTE (RE_Timed_Protected_Entry_Call), Loc),
- Parameter_Associations => Parms));
+ Stmt := First (Stmts);
+ while Nkind (Stmt) /= N_Procedure_Call_Statement loop
+ Next (Stmt);
+ end loop;
- else
- Parm := First (Parms);
+ -- Do the assignement at this stage only because the evaluation
+ -- of the expression must not occur before (see ACVC C97302A).
- while Present (Parm)
- and then not Is_RTE (Etype (Parm), RE_Protected_Entry_Index)
+ Insert_Before (Stmt,
+ Make_Assignment_Statement (Loc,
+ Name => New_Reference_To (D, Loc),
+ Expression => D_Conv));
+
+ Call := Stmt;
+ Params := Parameter_Associations (Call);
+
+ -- For a protected type, we build a Timed_Protected_Entry_Call
+
+ if Is_Protected_Type (Etype (Concval)) then
+
+ -- Create a new call statement
+
+ Param := First (Params);
+ while Present (Param)
+ and then not Is_RTE (Etype (Param), RE_Call_Modes)
loop
- Next (Parm);
+ Next (Param);
end loop;
- Remove (Parm);
+ Dummy := Remove_Next (Next (Param));
- Rewrite (Call,
- Make_Procedure_Call_Statement (Loc,
- Name => New_Reference_To (
- RTE (RE_Timed_Protected_Single_Entry_Call), Loc),
- Parameter_Associations => Parms));
- end if;
+ -- Remove garbage is following the Cancel_Param if present
- -- For the task case, build a Timed_Task_Entry_Call
+ Dummy := Next (Param);
- else
- -- Create a new call statement
+ -- Remove the mode of the Protected_Entry_Call call, then remove
+ -- the Communication_Block of the Protected_Entry_Call call, and
+ -- finally add Duration and a Delay_Mode parameter
- Append_To (Parms, New_Reference_To (D, Loc));
- Append_To (Parms, New_Reference_To (M, Loc));
- Append_To (Parms, New_Reference_To (B, Loc));
+ pragma Assert (Present (Param));
+ Rewrite (Param, New_Reference_To (D, Loc));
- Rewrite (Call,
- Make_Procedure_Call_Statement (Loc,
- Name => New_Reference_To (RTE (RE_Timed_Task_Entry_Call), Loc),
- Parameter_Associations => Parms));
+ Rewrite (Dummy, New_Reference_To (M, Loc));
- end if;
+ -- Add a Boolean flag for successful entry call
- Append_To (Stmts,
- Make_Implicit_If_Statement (N,
- Condition => New_Reference_To (B, Loc),
- Then_Statements => E_Stats,
- Else_Statements => D_Stats));
+ Append_To (Params, New_Reference_To (B, Loc));
+
+ if Abort_Allowed
+ or else Restriction_Active (No_Entry_Queue) = False
+ or else Number_Entries (Etype (Concval)) > 1
+ then
+ Rewrite (Call,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (RTE (
+ RE_Timed_Protected_Entry_Call), Loc),
+ Parameter_Associations => Params));
+ else
+ Param := First (Params);
+ while Present (Param)
+ and then not Is_RTE (Etype (Param), RE_Protected_Entry_Index)
+ loop
+ Next (Param);
+ end loop;
+
+ Remove (Param);
+
+ Rewrite (Call,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Reference_To (
+ RTE (RE_Timed_Protected_Single_Entry_Call), Loc),
+ Parameter_Associations => Params));
+ end if;
+
+ -- For the task case, build a Timed_Task_Entry_Call
+
+ else
+ -- Create a new call statement
+
+ Append_To (Params, New_Reference_To (D, Loc));
+ Append_To (Params, New_Reference_To (M, Loc));
+ Append_To (Params, New_Reference_To (B, Loc));
+
+ Rewrite (Call,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Timed_Task_Entry_Call), Loc),
+ Parameter_Associations => Params));
+ end if;
+
+ Append_To (Stmts,
+ Make_Implicit_If_Statement (N,
+ Condition => New_Reference_To (B, Loc),
+ Then_Statements => E_Stats,
+ Else_Statements => D_Stats));
+ end if;
Rewrite (N,
Make_Block_Statement (Loc,
end if;
end External_Subprogram;
+ ------------------------------
+ -- Extract_Dispatching_Call --
+ ------------------------------
+
+ procedure Extract_Dispatching_Call
+ (N : Node_Id;
+ Call_Ent : out Entity_Id;
+ Object : out Entity_Id;
+ Actuals : out List_Id;
+ Formals : out List_Id)
+ is
+ Call_Nam : Node_Id;
+
+ begin
+ pragma Assert (Nkind (N) = N_Procedure_Call_Statement);
+
+ if Present (Original_Node (N)) then
+ Call_Nam := Name (Original_Node (N));
+ else
+ Call_Nam := Name (N);
+ end if;
+
+ -- Retrieve the name of the dispatching procedure. It contains the
+ -- dispatch table slot number.
+
+ loop
+ case Nkind (Call_Nam) is
+ when N_Identifier =>
+ exit;
+
+ when N_Selected_Component =>
+ Call_Nam := Selector_Name (Call_Nam);
+
+ when others =>
+ raise Program_Error;
+
+ end case;
+ end loop;
+
+ Actuals := Parameter_Associations (N);
+ Call_Ent := Entity (Call_Nam);
+ Formals := Parameter_Specifications (Parent (Call_Ent));
+ Object := First (Actuals);
+
+ if Present (Original_Node (Object)) then
+ Object := Original_Node (Object);
+ end if;
+ end Extract_Dispatching_Call;
+
-------------------
-- Extract_Entry --
-------------------
Ename := Selector_Name (Nam);
Index := Empty;
- -- For a member of an entry family, the name is an indexed
- -- component where the prefix is a selected component,
- -- whose prefix in turn is the task value, and whose
- -- selector is the entry family. The single expression in
- -- the expressions list of the indexed component is the
- -- subscript for the family.
+ -- For a member of an entry family, the name is an indexed component
+ -- where the prefix is a selected component, whose prefix in turn is
+ -- the task value, and whose selector is the entry family. The single
+ -- expression in the expressions list of the indexed component is the
+ -- subscript for the family.
- else
- pragma Assert (Nkind (Nam) = N_Indexed_Component);
+ else pragma Assert (Nkind (Nam) = N_Indexed_Component);
Concval := Prefix (Prefix (Nam));
Ename := Selector_Name (Prefix (Nam));
Index := First (Expressions (Nam));
if Has_Entry
or else Has_Interrupt_Handler (Ptyp)
or else Has_Attach_Handler (Ptyp)
+ or else (Ada_Version >= Ada_05
+ and then Present (Interface_List (Parent (Ptyp))))
then
-- Compiler_Info parameter. This parameter allows entry body
-- procedures and barrier functions to be called from the runtime.
return Next_Op;
end Next_Protected_Operation;
+ --------------------------
+ -- Parameter_Block_Pack --
+ --------------------------
+
+ function Parameter_Block_Pack
+ (Loc : Source_Ptr;
+ Blk_Typ : Entity_Id;
+ Actuals : List_Id;
+ Formals : List_Id;
+ Decls : List_Id;
+ Stmts : List_Id) return Node_Id
+ is
+ Actual : Entity_Id;
+ Blk_Nam : Node_Id;
+ Formal : Entity_Id;
+ Params : List_Id;
+ Temp_Asn : Node_Id;
+ Temp_Nam : Node_Id;
+
+ begin
+ Actual := First (Actuals);
+ Formal := Defining_Identifier (First (Formals));
+ Params := New_List;
+
+ while Present (Actual) loop
+ if Is_By_Copy_Type (Etype (Actual)) then
+ -- Generate:
+ -- Jnn : aliased <formal-type>
+
+ Temp_Nam :=
+ Make_Defining_Identifier (Loc, New_Internal_Name ('J'));
+
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Aliased_Present =>
+ True,
+ Defining_Identifier =>
+ Temp_Nam,
+ Object_Definition =>
+ New_Reference_To (Etype (Formal), Loc)));
+
+ if Ekind (Formal) /= E_Out_Parameter then
+
+ -- Generate:
+ -- Jnn := <actual>
+
+ Temp_Asn :=
+ New_Reference_To (Temp_Nam, Loc);
+
+ Set_Assignment_OK (Temp_Asn);
+
+ Append_To (Stmts,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Temp_Asn,
+ Expression =>
+ New_Copy_Tree (Actual)));
+ end if;
+
+ -- Generate:
+ -- Jnn'unchecked_access
+
+ Append_To (Params,
+ Make_Attribute_Reference (Loc,
+ Attribute_Name =>
+ Name_Unchecked_Access,
+ Prefix =>
+ New_Reference_To (Temp_Nam, Loc)));
+ else
+ Append_To (Params,
+ Make_Reference (Loc, New_Copy_Tree (Actual)));
+ end if;
+
+ Next_Actual (Actual);
+ Next_Formal_With_Extras (Formal);
+ end loop;
+
+ -- Generate:
+ -- P : Ann := (
+ -- J1'unchecked_access;
+ -- <actual2>'reference;
+ -- ...);
+
+ Blk_Nam := Make_Defining_Identifier (Loc, Name_uP);
+
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Blk_Nam,
+ Object_Definition =>
+ New_Reference_To (Blk_Typ, Loc),
+ Expression =>
+ Make_Aggregate (Loc, Params)));
+
+ -- Return:
+ -- P'address
+
+ return
+ Make_Attribute_Reference (Loc,
+ Attribute_Name =>
+ Name_Address,
+ Prefix =>
+ New_Reference_To (Blk_Nam, Loc));
+ end Parameter_Block_Pack;
+
+ ----------------------------
+ -- Parameter_Block_Unpack --
+ ----------------------------
+
+ function Parameter_Block_Unpack
+ (Loc : Source_Ptr;
+ Actuals : List_Id;
+ Formals : List_Id) return List_Id
+ is
+ Actual : Entity_Id;
+ Asnmt : Node_Id;
+ Formal : Entity_Id;
+ Result : constant List_Id := New_List;
+
+ At_Least_One_Asnmt : Boolean := False;
+
+ begin
+ Actual := First (Actuals);
+ Formal := Defining_Identifier (First (Formals));
+
+ while Present (Actual) loop
+ if Is_By_Copy_Type (Etype (Actual))
+ and then Ekind (Formal) /= E_In_Parameter
+ then
+ At_Least_One_Asnmt := True;
+
+ -- Generate:
+ -- <actual> := P.<formal>;
+
+ Asnmt :=
+ Make_Assignment_Statement (Loc,
+ Name =>
+ New_Copy (Actual),
+ Expression =>
+ Make_Explicit_Dereference (Loc,
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Make_Identifier (Loc, Name_uP),
+ Selector_Name =>
+ Make_Identifier (Loc, Chars (Formal)))));
+
+ Set_Assignment_OK (Name (Asnmt));
+
+ Append_To (Result, Asnmt);
+ end if;
+
+ Next_Actual (Actual);
+ Next_Formal_With_Extras (Formal);
+ end loop;
+
+ if At_Least_One_Asnmt then
+ return Result;
+ end if;
+
+ return New_List (Make_Null_Statement (Loc));
+ end Parameter_Block_Unpack;
+
----------------------
-- Set_Discriminals --
----------------------
if Has_Discriminants (Pdef) then
D := First_Discriminant (Pdef);
-
while Present (D) loop
D_Minal :=
Make_Defining_Identifier (Sloc (D),
Set_Esize (Priv, Esize (Etype (P_Id)));
Set_Alignment (Priv, Alignment (Etype (P_Id)));
- -- If the type of the component is an itype, we must
- -- create a new itype for the corresponding prival in
- -- each protected operation, to avoid scoping problems.
- -- We create new itypes by copying the tree for the
- -- component definition.
+ -- If the type of the component is an itype, we must create a
+ -- new itype for the corresponding prival in each protected
+ -- operation, to avoid scoping problems. We create new itypes
+ -- by copying the tree for the component definition.
if Is_Itype (Etype (P_Id)) then
Append_Elmt (P_Id, Assoc_L);
end loop;
end if;
- -- There is one more implicit private declaration: the object
- -- itself. A "prival" for this is attached to the protected
- -- body defining identifier.
+ -- There is one more implicit private decl: the object itself. "prival"
+ -- for this is attached to the protected body defining identifier.
Body_Ent := Corresponding_Body (Dec);
Update_Array_Bounds (Etype (Defining_Identifier (N)));
return OK;
- -- For array components of discriminated records, use the
- -- base type directly, because it may depend indirectly
- -- on the discriminants of the protected type. Cleaner would
- -- be a systematic mechanism to compute actual subtypes of
- -- private components ???
+ -- For array components of discriminated records, use the base type
+ -- directly, because it may depend indirectly on the discriminants of
+ -- the protected type.
+
+ -- Cleaner would be a systematic mechanism to compute actual subtypes
+ -- of private components???
elsif Nkind (N) in N_Has_Etype
and then Present (Etype (N))
procedure Update_Array_Bounds (E : Entity_Id) is
Ind : Node_Id;
-
begin
Ind := First_Index (E);
-
while Present (Ind) loop
Update_Prival_Subtypes (Type_Low_Bound (Etype (Ind)));
Update_Prival_Subtypes (Type_High_Bound (Etype (Ind)));
procedure Update_Index_Types (N : Node_Id) is
Indx1 : Node_Id;
I_Typ : Node_Id;
+
begin
- -- If the prefix has an actual subtype that is different
- -- from the nominal one, update the types of the indices,
- -- so that the proper constraints are applied. Do not
- -- apply this transformation to a packed array, where the
- -- index type is computed for a byte array and is different
- -- from the source index.
+ -- If the prefix has an actual subtype that is different from the
+ -- nominal one, update the types of the indices, so that the proper
+ -- constraints are applied. Do not apply this transformation to a
+ -- packed array, where the index type is computed for a byte array
+ -- and is different from the source index.
if Nkind (Parent (N)) = N_Indexed_Component
and then
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
package Exp_Ch9 is
+ type Subprogram_Protection_Mode is
+ (Dispatching_Mode,
+ Protected_Mode,
+ Unprotected_Mode);
+ -- This type is used to distinguish the different protection modes of a
+ -- protected subprogram.
+
procedure Add_Discriminal_Declarations
(Decls : List_Id;
Typ : Entity_Id;
-- declarative part.
function Build_Protected_Sub_Specification
- (N : Node_Id;
- Prottyp : Entity_Id;
- Unprotected : Boolean := False)
- return Node_Id;
+ (N : Node_Id;
+ Prottyp : Entity_Id;
+ Mode : Subprogram_Protection_Mode) return Node_Id;
-- Build specification for protected subprogram. This is called when
-- expanding a protected type, and also when expanding the declaration for
-- an Access_To_Protected_Subprogram type. In the latter case, Prottyp is
-- routine to make sure Complete_Master is called on exit).
procedure Expand_Access_Protected_Subprogram_Type (N : Node_Id);
- -- Build Equivalent_Type for an Access_to_protected_Subprogram.
+ -- Build Equivalent_Type for an Access_to_protected_Subprogram
procedure Expand_Accept_Declarations (N : Node_Id; Ent : Entity_Id);
-- Expand declarations required for accept statement. See bodies of
with Snames; use Snames;
with Stand; use Stand;
with Tbuild; use Tbuild;
-with Ttypes; use Ttypes;
with Uintp; use Uintp;
package body Exp_Disp is
+ --------------------------------
+ -- Select_Expansion_Utilities --
+ --------------------------------
+
+ -- The following package contains helper routines used in the expansion of
+ -- dispatching asynchronous, conditional and timed selects.
+
+ package Select_Expansion_Utilities is
+ procedure Build_B
+ (Loc : Source_Ptr;
+ Params : List_Id);
+ -- Generate:
+ -- B : out Communication_Block
+
+ procedure Build_C
+ (Loc : Source_Ptr;
+ Params : List_Id);
+ -- Generate:
+ -- C : out Prim_Op_Kind
+
+ procedure Build_Common_Dispatching_Select_Statements
+ (Loc : Source_Ptr;
+ Typ : Entity_Id;
+ Stmts : List_Id);
+ -- Ada 2005 (AI-345): Generate statements that are common between
+ -- asynchronous, conditional and timed select expansion.
+
+ procedure Build_F
+ (Loc : Source_Ptr;
+ Params : List_Id);
+ -- Generate:
+ -- F : out Boolean
+
+ procedure Build_P
+ (Loc : Source_Ptr;
+ Params : List_Id);
+ -- Generate:
+ -- P : Address
+
+ procedure Build_S
+ (Loc : Source_Ptr;
+ Params : List_Id);
+ -- Generate:
+ -- S : Integer
+
+ procedure Build_T
+ (Loc : Source_Ptr;
+ Typ : Entity_Id;
+ Params : List_Id);
+ -- Generate:
+ -- T : in out Typ
+ end Select_Expansion_Utilities;
+
+ package body Select_Expansion_Utilities is
+
+ -------------
+ -- Build_B --
+ -------------
+
+ procedure Build_B
+ (Loc : Source_Ptr;
+ Params : List_Id)
+ is
+ begin
+ Append_To (Params,
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uB),
+ Parameter_Type =>
+ New_Reference_To (RTE (RE_Communication_Block), Loc),
+ Out_Present => True));
+ end Build_B;
+
+ -------------
+ -- Build_C --
+ -------------
+
+ procedure Build_C
+ (Loc : Source_Ptr;
+ Params : List_Id)
+ is
+ begin
+ Append_To (Params,
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uC),
+ Parameter_Type =>
+ New_Reference_To (RTE (RE_Prim_Op_Kind), Loc),
+ Out_Present => True));
+ end Build_C;
+
+ ------------------------------------------------
+ -- Build_Common_Dispatching_Select_Statements --
+ ------------------------------------------------
+
+ procedure Build_Common_Dispatching_Select_Statements
+ (Loc : Source_Ptr;
+ Typ : Entity_Id;
+ Stmts : List_Id)
+ is
+ DT_Ptr : Entity_Id;
+ DT_Ptr_Typ : Entity_Id := Typ;
+
+ begin
+ -- Typ may be a derived type, climb the derivation chain in order to
+ -- find the root.
+
+ while Present (Parent_Subtype (DT_Ptr_Typ)) loop
+ DT_Ptr_Typ := Parent_Subtype (DT_Ptr_Typ);
+ end loop;
+
+ DT_Ptr := Node (First_Elmt (Access_Disp_Table (DT_Ptr_Typ)));
+
+ -- Generate:
+ -- C := get_prim_op_kind (tag! (<type>VP), S);
+
+ -- where C is the out parameter capturing the call kind and S is the
+ -- dispatch table slot number.
+
+ Append_To (Stmts,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Identifier (Loc, Name_uC),
+ Expression =>
+ Make_DT_Access_Action (Typ,
+ Action =>
+ Get_Prim_Op_Kind,
+ Args =>
+ New_List (
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To (DT_Ptr, Loc)),
+ Make_Identifier (Loc, Name_uS)))));
+
+ -- Generate:
+ -- if C = POK_Procedure
+ -- or else C = POK_Protected_Procedure
+ -- or else C = POK_Task_Procedure;
+ -- then
+ -- F := True;
+ -- return;
+
+ -- where F is the out parameter capturing the status of a potential
+ -- entry call.
+
+ Append_To (Stmts,
+ Make_If_Statement (Loc,
+
+ Condition =>
+ Make_Or_Else (Loc,
+ Left_Opnd =>
+ Make_Op_Eq (Loc,
+ Left_Opnd =>
+ Make_Identifier (Loc, Name_uC),
+ Right_Opnd =>
+ New_Reference_To (RTE (RE_POK_Procedure), Loc)),
+ Right_Opnd =>
+ Make_Or_Else (Loc,
+ Left_Opnd =>
+ Make_Op_Eq (Loc,
+ Left_Opnd =>
+ Make_Identifier (Loc, Name_uC),
+ Right_Opnd =>
+ New_Reference_To (RTE (
+ RE_POK_Protected_Procedure), Loc)),
+ Right_Opnd =>
+ Make_Op_Eq (Loc,
+ Left_Opnd =>
+ Make_Identifier (Loc, Name_uC),
+ Right_Opnd =>
+ New_Reference_To (RTE (
+ RE_POK_Task_Procedure), Loc)))),
+
+ Then_Statements =>
+ New_List (
+ Make_Assignment_Statement (Loc,
+ Name => Make_Identifier (Loc, Name_uF),
+ Expression => New_Reference_To (Standard_True, Loc)),
+
+ Make_Return_Statement (Loc))));
+ end Build_Common_Dispatching_Select_Statements;
+
+ -------------
+ -- Build_F --
+ -------------
+
+ procedure Build_F
+ (Loc : Source_Ptr;
+ Params : List_Id)
+ is
+ begin
+ Append_To (Params,
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uF),
+ Parameter_Type =>
+ New_Reference_To (Standard_Boolean, Loc),
+ Out_Present => True));
+ end Build_F;
+
+ -------------
+ -- Build_P --
+ -------------
+
+ procedure Build_P
+ (Loc : Source_Ptr;
+ Params : List_Id)
+ is
+ begin
+ Append_To (Params,
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uP),
+ Parameter_Type =>
+ New_Reference_To (RTE (RE_Address), Loc)));
+ end Build_P;
+
+ -------------
+ -- Build_S --
+ -------------
+
+ procedure Build_S
+ (Loc : Source_Ptr;
+ Params : List_Id)
+ is
+ begin
+ Append_To (Params,
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uS),
+ Parameter_Type =>
+ New_Reference_To (Standard_Integer, Loc)));
+ end Build_S;
+
+ -------------
+ -- Build_T --
+ -------------
+
+ procedure Build_T
+ (Loc : Source_Ptr;
+ Typ : Entity_Id;
+ Params : List_Id)
+ is
+ begin
+ Append_To (Params,
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uT),
+ Parameter_Type =>
+ New_Reference_To (Typ, Loc),
+ In_Present => True,
+ Out_Present => True));
+ end Build_T;
+ end Select_Expansion_Utilities;
+
+ package SEU renames Select_Expansion_Utilities;
+
Ada_Actions : constant array (DT_Access_Action) of RE_Id :=
(CW_Membership => RE_CW_Membership,
IW_Membership => RE_IW_Membership,
DT_Entry_Size => RE_DT_Entry_Size,
DT_Prologue_Size => RE_DT_Prologue_Size,
Get_Access_Level => RE_Get_Access_Level,
+ Get_Entry_Index => RE_Get_Entry_Index,
Get_External_Tag => RE_Get_External_Tag,
Get_Prim_Op_Address => RE_Get_Prim_Op_Address,
+ Get_Prim_Op_Kind => RE_Get_Prim_Op_Kind,
Get_RC_Offset => RE_Get_RC_Offset,
Get_Remotely_Callable => RE_Get_Remotely_Callable,
Inherit_DT => RE_Inherit_DT,
Register_Interface_Tag => RE_Register_Interface_Tag,
Register_Tag => RE_Register_Tag,
Set_Access_Level => RE_Set_Access_Level,
+ Set_Entry_Index => RE_Set_Entry_Index,
Set_Expanded_Name => RE_Set_Expanded_Name,
Set_External_Tag => RE_Set_External_Tag,
Set_Prim_Op_Address => RE_Set_Prim_Op_Address,
+ Set_Prim_Op_Kind => RE_Set_Prim_Op_Kind,
Set_RC_Offset => RE_Set_RC_Offset,
Set_Remotely_Callable => RE_Set_Remotely_Callable,
Set_TSD => RE_Set_TSD,
DT_Entry_Size => False,
DT_Prologue_Size => False,
Get_Access_Level => False,
+ Get_Entry_Index => False,
Get_External_Tag => False,
Get_Prim_Op_Address => False,
+ Get_Prim_Op_Kind => False,
Get_Remotely_Callable => False,
Get_RC_Offset => False,
Inherit_DT => True,
Register_Interface_Tag => True,
Register_Tag => True,
Set_Access_Level => True,
+ Set_Entry_Index => True,
Set_Expanded_Name => True,
Set_External_Tag => True,
Set_Prim_Op_Address => True,
+ Set_Prim_Op_Kind => True,
Set_RC_Offset => True,
Set_Remotely_Callable => True,
Set_TSD => True,
DT_Entry_Size => 0,
DT_Prologue_Size => 0,
Get_Access_Level => 1,
+ Get_Entry_Index => 2,
Get_External_Tag => 1,
Get_Prim_Op_Address => 2,
+ Get_Prim_Op_Kind => 2,
Get_RC_Offset => 1,
Get_Remotely_Callable => 1,
Inherit_DT => 3,
Register_Interface_Tag => 2,
Register_Tag => 1,
Set_Access_Level => 2,
+ Set_Entry_Index => 3,
Set_Expanded_Name => 2,
Set_External_Tag => 2,
Set_Prim_Op_Address => 3,
+ Set_Prim_Op_Kind => 3,
Set_RC_Offset => 2,
Set_Remotely_Callable => 2,
Set_TSD => 2,
TSD_Entry_Size => 0,
TSD_Prologue_Size => 0);
- function Build_Anonymous_Access_Type
- (Directly_Designated_Type : Entity_Id;
- Related_Nod : Node_Id) return Entity_Id;
- -- Returns a decorated entity corresponding with an anonymous access type.
- -- Used to generate unchecked type conversion of an address.
-
procedure Collect_All_Interfaces (T : Entity_Id);
-- Ada 2005 (AI-251): Collect the whole list of interfaces that are
-- directly or indirectly implemented by T. Used to compute the size
-- Check if the type has a private view or if the public view appears
-- in the visible part of a package spec.
- ----------------------------------
- -- Build_Anonymous_Access_Type --
- ----------------------------------
-
- function Build_Anonymous_Access_Type
- (Directly_Designated_Type : Entity_Id;
- Related_Nod : Node_Id) return Entity_Id
- is
- New_E : Entity_Id;
-
- begin
- New_E := Create_Itype (Ekind => E_Anonymous_Access_Type,
- Related_Nod => Related_Nod,
- Scope_Id => Current_Scope);
-
- Set_Etype (New_E, New_E);
- Init_Size_Align (New_E);
- Init_Size (New_E, System_Address_Size);
- Set_Directly_Designated_Type (New_E, Directly_Designated_Type);
- Set_Is_First_Subtype (New_E);
-
- return New_E;
- end Build_Anonymous_Access_Type;
+ function Prim_Op_Kind
+ (Prim : Entity_Id;
+ Typ : Entity_Id) return Node_Id;
+ -- Ada 2005 (AI-345): Determine the primitive operation kind of Prim
+ -- according to its type Typ. Return a reference to an RTE Prim_Op_Kind
+ -- enumeration value.
----------------------------
-- Collect_All_Interfaces --
-------------------
procedure Add_Interface (Iface : Entity_Id) is
- Elmt : Elmt_Id := First_Elmt (Abstract_Interfaces (T));
+ Elmt : Elmt_Id;
begin
+ Elmt := First_Elmt (Abstract_Interfaces (T));
while Present (Elmt) and then Node (Elmt) /= Iface loop
Next_Elmt (Elmt);
end loop;
if Is_Non_Empty_List (Interface_List (Nod)) then
Id := First (Interface_List (Nod));
-
while Present (Id) loop
-
Iface := Etype (Id);
if Is_Interface (Iface) then
elsif TSS_Name = TSS_Deep_Finalize then
return Uint_10;
+ elsif Chars (E) = Name_uDisp_Asynchronous_Select then
+ return Uint_11;
+
+ elsif Chars (E) = Name_uDisp_Conditional_Select then
+ return Uint_12;
+
+ elsif Chars (E) = Name_uDisp_Get_Prim_Op_Kind then
+ return Uint_13;
+
+ elsif Chars (E) = Name_uDisp_Timed_Select then
+ return Uint_14;
+
else
raise Program_Error;
end if;
else
declare
- Formal : Entity_Id := First_Formal (Subp);
+ Formal : Entity_Id;
begin
+ Formal := First_Formal (Subp);
while Present (Formal) loop
if Is_Controlling_Formal (Formal) then
if Is_Access_Type (Etype (Formal)) then
Typ := Root_Type (CW_Typ);
+ if Ekind (Typ) = E_Incomplete_Type then
+ Typ := Non_Limited_View (Typ);
+ end if;
+
if not Is_Limited_Type (Typ) then
Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
end if;
Loc : constant Source_Ptr := Sloc (N);
Operand : constant Node_Id := Expression (N);
Operand_Typ : Entity_Id := Etype (Operand);
- Target_Type : Entity_Id := Etype (N);
+ Iface_Typ : Entity_Id := Etype (N);
Iface_Tag : Entity_Id;
+ Fent : Entity_Id;
+ Func : Node_Id;
+ P : Node_Id;
+ Null_Op_Nod : Node_Id;
begin
pragma Assert (Nkind (Operand) /= N_Attribute_Reference);
- -- Ada 2005 (AI-345): Set Operand_Typ and Handle task interfaces
+ -- Ada 2005 (AI-345): Handle task interfaces
if Ekind (Operand_Typ) = E_Task_Type
or else Ekind (Operand_Typ) = E_Protected_Type
Operand_Typ := Corresponding_Record_Type (Operand_Typ);
end if;
- if Is_Access_Type (Target_Type) then
- Target_Type := Etype (Directly_Designated_Type (Target_Type));
+ -- Handle access types to interfaces
- elsif Is_Class_Wide_Type (Target_Type) then
- Target_Type := Etype (Target_Type);
+ if Is_Access_Type (Iface_Typ) then
+ Iface_Typ := Etype (Directly_Designated_Type (Iface_Typ));
end if;
- pragma Assert (not Is_Class_Wide_Type (Target_Type)
- and then Is_Interface (Target_Type));
+ -- Handle class-wide interface types. This conversion can appear
+ -- explicitly in the source code. Example: I'Class (Obj)
- Iface_Tag := Find_Interface_Tag (Operand_Typ, Target_Type);
+ if Is_Class_Wide_Type (Iface_Typ) then
+ Iface_Typ := Etype (Iface_Typ);
+ end if;
+
+ pragma Assert (not Is_Class_Wide_Type (Iface_Typ)
+ and then Is_Interface (Iface_Typ));
+ Iface_Tag := Find_Interface_Tag (Operand_Typ, Iface_Typ);
pragma Assert (Iface_Tag /= Empty);
- Rewrite (N,
- Unchecked_Convert_To (Etype (N),
- Make_Attribute_Reference (Loc,
- Prefix => Make_Selected_Component (Loc,
- Prefix => Relocate_Node (Expression (N)),
- Selector_Name => New_Occurrence_Of (Iface_Tag, Loc)),
- Attribute_Name => Name_Address)));
+ -- Keep separate access types to interfaces because one internal
+ -- function is used to handle the null value (see following comment)
+
+ if not Is_Access_Type (Etype (N)) then
+ Rewrite (N,
+ Unchecked_Convert_To (Etype (N),
+ Make_Selected_Component (Loc,
+ Prefix => Relocate_Node (Expression (N)),
+ Selector_Name =>
+ New_Occurrence_Of (Iface_Tag, Loc))));
+
+ else
+ -- Build internal function to handle the case in which the
+ -- actual is null. If the actual is null returns null because
+ -- no displacement is required; otherwise performs a type
+ -- conversion that will be expanded in the code that returns
+ -- the value of the displaced actual. That is:
+
+ -- function Func (O : Operand_Typ) return Iface_Typ is
+ -- begin
+ -- if O = null then
+ -- return null;
+ -- else
+ -- return Iface_Typ!(O);
+ -- end if;
+ -- end Func;
+
+ Fent :=
+ Make_Defining_Identifier (Loc, New_Internal_Name ('F'));
+
+ -- Decorate the "null" in the if-statement condition
+
+ Null_Op_Nod := Make_Null (Loc);
+ Set_Etype (Null_Op_Nod, Etype (Operand));
+ Set_Analyzed (Null_Op_Nod);
+
+ Func :=
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name => Fent,
+
+ Parameter_Specifications => New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uO),
+ Parameter_Type =>
+ New_Reference_To (Etype (Operand), Loc))),
+ Result_Definition =>
+ New_Reference_To (Etype (N), Loc)),
+
+ Declarations => Empty_List,
+
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (
+ Make_If_Statement (Loc,
+ Condition =>
+ Make_Op_Eq (Loc,
+ Left_Opnd => Make_Identifier (Loc, Name_uO),
+ Right_Opnd => Null_Op_Nod),
+ Then_Statements => New_List (
+ Make_Return_Statement (Loc,
+ Make_Null (Loc))),
+ Else_Statements => New_List (
+ Make_Return_Statement (Loc,
+ Unchecked_Convert_To (Etype (N),
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix => Relocate_Node (Expression (N)),
+ Selector_Name =>
+ New_Occurrence_Of (Iface_Tag, Loc)),
+ Attribute_Name => Name_Address))))))));
+
+ -- Insert the new declaration in the nearest enclosing scope
+ -- that has declarations.
+
+ P := N;
+ while not Has_Declarations (Parent (P)) loop
+ P := Parent (P);
+ end loop;
+
+ if Is_List_Member (P) then
+ Insert_Before (P, Func);
+
+ elsif Nkind (Parent (P)) = N_Package_Specification then
+ Append_To (Visible_Declarations (Parent (P)), Func);
+
+ else
+ Append_To (Declarations (Parent (P)), Func);
+ end if;
+
+ Analyze (Func);
+
+ Rewrite (N,
+ Make_Function_Call (Loc,
+ Name => New_Reference_To (Fent, Loc),
+ Parameter_Associations => New_List (
+ Relocate_Node (Expression (N)))));
+ end if;
Analyze (N);
end Expand_Interface_Conversion;
procedure Expand_Interface_Actuals (Call_Node : Node_Id) is
Loc : constant Source_Ptr := Sloc (Call_Node);
Actual : Node_Id;
+ Actual_Dup : Node_Id;
Actual_Typ : Entity_Id;
+ Anon : Entity_Id;
Conversion : Node_Id;
Formal : Entity_Id;
Formal_Typ : Entity_Id;
Subp : Entity_Id;
Nam : Name_Id;
+ Formal_DDT : Entity_Id;
+ Actual_DDT : Entity_Id;
begin
-- This subprogram is called directly from the semantics, so we need a
Formal := First_Formal (Subp);
Actual := First_Actual (Call_Node);
-
while Present (Formal) loop
- pragma Assert (Ekind (Etype (Etype (Formal)))
- /= E_Record_Type_With_Private);
-
-- Ada 2005 (AI-251): Conversion to interface to force "this"
- -- displacement
+ -- displacement.
Formal_Typ := Etype (Etype (Formal));
+
+ if Ekind (Formal_Typ) = E_Record_Type_With_Private then
+ Formal_Typ := Full_View (Formal_Typ);
+ end if;
+
+ if Is_Access_Type (Formal_Typ) then
+ Formal_DDT := Directly_Designated_Type (Formal_Typ);
+ end if;
+
Actual_Typ := Etype (Actual);
+ if Is_Access_Type (Actual_Typ) then
+ Actual_DDT := Directly_Designated_Type (Actual_Typ);
+ end if;
+
if Is_Interface (Formal_Typ) then
- Conversion := Convert_To (Formal_Typ, New_Copy_Tree (Actual));
- Rewrite (Actual, Conversion);
- Analyze_And_Resolve (Actual, Formal_Typ);
+ -- No need to displace the pointer if the type of the actual
+ -- is class-wide of the formal-type interface; in this case the
+ -- displacement of the pointer was already done at the point of
+ -- the call to the enclosing subprogram. This case corresponds
+ -- with the call to P (Obj) in the following example:
- Rewrite (Actual,
- Make_Explicit_Dereference (Loc,
- Unchecked_Convert_To
- (Build_Anonymous_Access_Type (Formal_Typ, Call_Node),
- Relocate_Node (Expression (Actual)))));
+ -- type I is interface;
+ -- procedure P (X : I) is abstract;
+
+ -- procedure General_Op (Obj : I'Class) is
+ -- begin
+ -- P (Obj);
+ -- end General_Op;
+
+ if Is_Class_Wide_Type (Actual_Typ)
+ and then Etype (Actual_Typ) = Formal_Typ
+ then
+ null;
+
+ -- No need to displace the pointer if the type of the actual is a
+ -- derivation of the formal-type interface because in this case
+ -- the interface primitives are located in the primary dispatch
+ -- table.
- Analyze_And_Resolve (Actual, Formal_Typ);
+ elsif Is_Ancestor (Formal_Typ, Actual_Typ) then
+ null;
+
+ else
+ Conversion := Convert_To (Formal_Typ, Relocate_Node (Actual));
+ Rewrite (Actual, Conversion);
+ Analyze_And_Resolve (Actual, Formal_Typ);
+ end if;
-- Anonymous access type
elsif Is_Access_Type (Formal_Typ)
- and then Is_Interface (Etype
- (Directly_Designated_Type
- (Formal_Typ)))
+ and then Is_Interface (Etype (Formal_DDT))
and then Interface_Present_In_Ancestor
- (Typ => Etype (Directly_Designated_Type
- (Actual_Typ)),
- Iface => Etype (Directly_Designated_Type
- (Formal_Typ)))
+ (Typ => Actual_DDT,
+ Iface => Etype (Formal_DDT))
then
-
if Nkind (Actual) = N_Attribute_Reference
and then
(Attribute_Name (Actual) = Name_Access
then
Nam := Attribute_Name (Actual);
- Conversion :=
- Convert_To
- (Etype (Directly_Designated_Type (Formal_Typ)),
- Prefix (Actual));
+ Conversion := Convert_To (Etype (Formal_DDT), Prefix (Actual));
Rewrite (Actual, Conversion);
-
- Analyze_And_Resolve (Actual,
- Etype (Directly_Designated_Type (Formal_Typ)));
+ Analyze_And_Resolve (Actual, Etype (Formal_DDT));
Rewrite (Actual,
Unchecked_Convert_To (Formal_Typ,
Make_Attribute_Reference (Loc,
- Prefix =>
- Relocate_Node (Prefix (Expression (Actual))),
+ Prefix => Relocate_Node (Actual),
Attribute_Name => Nam)));
Analyze_And_Resolve (Actual, Formal_Typ);
+ -- No need to displace the pointer if the actual is a class-wide
+ -- type of the formal-type interface because in this case the
+ -- displacement of the pointer was already done at the point of
+ -- the call to the enclosing subprogram (this case is similar
+ -- to the example described above for the non access-type case)
+
+ elsif Is_Class_Wide_Type (Actual_DDT)
+ and then Etype (Actual_DDT) = Formal_DDT
+ then
+ null;
+
+ -- No need to displace the pointer if the type of the actual is a
+ -- derivation of the interface (because in this case the interface
+ -- primitives are located in the primary dispatch table)
+
+ elsif Is_Ancestor (Formal_DDT, Actual_DDT) then
+ null;
+
else
- Conversion :=
- Convert_To (Formal_Typ, New_Copy_Tree (Actual));
- Rewrite (Actual, Conversion);
+ Actual_Dup := Relocate_Node (Actual);
+
+ if From_With_Type (Actual_Typ) then
+
+ -- If the type of the actual parameter comes from a limited
+ -- with-clause and the non-limited view is already available
+ -- we replace the anonymous access type by a duplicate decla
+ -- ration whose designated type is the non-limited view
+
+ if Ekind (Actual_DDT) = E_Incomplete_Type
+ and then Present (Non_Limited_View (Actual_DDT))
+ then
+ Anon := New_Copy (Actual_Typ);
+
+ if Is_Itype (Anon) then
+ Set_Scope (Anon, Current_Scope);
+ end if;
+
+ Set_Directly_Designated_Type (Anon,
+ Non_Limited_View (Actual_DDT));
+ Set_Etype (Actual_Dup, Anon);
+
+ elsif Is_Class_Wide_Type (Actual_DDT)
+ and then Ekind (Etype (Actual_DDT)) = E_Incomplete_Type
+ and then Present (Non_Limited_View (Etype (Actual_DDT)))
+ then
+ Anon := New_Copy (Actual_Typ);
+
+ if Is_Itype (Anon) then
+ Set_Scope (Anon, Current_Scope);
+ end if;
+
+ Set_Directly_Designated_Type (Anon,
+ New_Copy (Actual_DDT));
+ Set_Class_Wide_Type (Directly_Designated_Type (Anon),
+ New_Copy (Class_Wide_Type (Actual_DDT)));
+ Set_Etype (Directly_Designated_Type (Anon),
+ Non_Limited_View (Etype (Actual_DDT)));
+ Set_Etype (
+ Class_Wide_Type (Directly_Designated_Type (Anon)),
+ Non_Limited_View (Etype (Actual_DDT)));
+ Set_Etype (Actual_Dup, Anon);
+ end if;
+ end if;
+
+ Conversion := Convert_To (Formal_Typ, Actual_Dup);
+ Rewrite (Actual, Conversion);
Analyze_And_Resolve (Actual, Formal_Typ);
end if;
end if;
(N : Node_Id;
Thunk_Alias : Entity_Id;
Thunk_Id : Entity_Id;
- Iface_Tag : Entity_Id) return Node_Id
+ Thunk_Tag : Entity_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (N);
Actuals : constant List_Id := New_List;
Decl : constant List_Id := New_List;
Formals : constant List_Id := New_List;
- Thunk_Tag : constant Node_Id := Iface_Tag;
Target : Entity_Id;
New_Code : Node_Id;
Formal : Node_Id;
New_Formal : Node_Id;
Decl_1 : Node_Id;
Decl_2 : Node_Id;
- Subtyp_Mark : Node_Id;
+ E : Entity_Id;
begin
-
-- Traverse the list of alias to find the final target
Target := Thunk_Alias;
-
while Present (Alias (Target)) loop
Target := Alias (Target);
end loop;
-- Duplicate the formals
- Formal := First_Formal (Thunk_Alias);
-
+ Formal := First_Formal (Target);
+ E := First_Formal (N);
while Present (Formal) loop
New_Formal := Copy_Separate_Tree (Parent (Formal));
- -- Handle the case in which the subprogram covering
- -- the interface has been inherited:
+ -- Propagate the parameter type to the copy. This is required to
+ -- properly handle the case in which the subprogram covering the
+ -- interface has been inherited:
-- Example:
-- type I is interface;
-- type DT is new T and I with ...
- if Is_Controlling_Formal (Formal) then
- Set_Parameter_Type (New_Formal,
- New_Reference_To (Etype (First_Entity (N)), Loc));
- end if;
-
+ Set_Parameter_Type (New_Formal, New_Reference_To (Etype (E), Loc));
Append_To (Formals, New_Formal);
+
Next_Formal (Formal);
+ Next_Formal (E);
end loop;
- if Ekind (First_Formal (Thunk_Alias)) = E_In_Parameter
- and then Ekind (Etype (First_Formal (Thunk_Alias)))
+ if Ekind (First_Formal (Target)) = E_In_Parameter
+ and then Ekind (Etype (First_Formal (Target)))
= E_Anonymous_Access_Type
then
-
-- Generate:
-- type T is access all <<type of the first formal>>
Subtype_Indication =>
New_Reference_To
(Directly_Designated_Type
- (Etype (First_Formal (Thunk_Alias))), Loc)
- ));
+ (Etype (First_Formal (Target))), Loc)));
Decl_1 :=
Make_Object_Declaration (Loc,
Next (Formal);
end loop;
- if Ekind (Thunk_Alias) = E_Procedure then
+ if Ekind (Target) = E_Procedure then
New_Code :=
Make_Subprogram_Body (Loc,
Specification =>
Name => New_Occurrence_Of (Target, Loc),
Parameter_Associations => Actuals))));
- else pragma Assert (Ekind (Thunk_Alias) = E_Function);
-
- if not Present (Alias (Thunk_Alias)) then
- Subtyp_Mark := Subtype_Mark (Parent (Thunk_Alias));
- else
- -- The last element in the alias list has the correct subtype_mark
- -- of the function result
-
- declare
- E : Entity_Id := Alias (Thunk_Alias);
- begin
- while Present (Alias (E)) loop
- E := Alias (E);
- end loop;
- Subtyp_Mark := Subtype_Mark (Parent (E));
- end;
- end if;
+ else pragma Assert (Ekind (Target) = E_Function);
New_Code :=
Make_Subprogram_Body (Loc,
Make_Function_Specification (Loc,
Defining_Unit_Name => Thunk_Id,
Parameter_Specifications => Formals,
- Subtype_Mark => New_Copy (Subtyp_Mark)),
+ Result_Definition =>
+ New_Copy (Result_Definition (Parent (Target)))),
Declarations => Decl,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Selector_Name => Make_Identifier (Loc, Name_uTag))));
end Get_Remotely_Callable;
+ ------------------------------------------
+ -- Init_Predefined_Interface_Primitives --
+ ------------------------------------------
+
+ function Init_Predefined_Interface_Primitives
+ (Typ : Entity_Id) return List_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Typ);
+ DT_Ptr : constant Node_Id :=
+ Node (First_Elmt (Access_Disp_Table (Typ)));
+ Result : constant List_Id := New_List;
+ AI : Elmt_Id;
+
+ begin
+ -- No need to inherit primitives if it an abstract interface type
+
+ if Is_Interface (Typ) then
+ return Result;
+ end if;
+
+ AI := Next_Elmt (First_Elmt (Access_Disp_Table (Typ)));
+ while Present (AI) loop
+ -- All the secondary tables inherit the dispatch table entries
+ -- associated with predefined primitives.
+
+ -- Generate:
+ -- Inherit_DT (T'Tag, Iface'Tag, Default_Prim_Op_Count);
+
+ Append_To (Result,
+ Make_DT_Access_Action (Typ,
+ Action => Inherit_DT,
+ Args => New_List (
+ Node1 => New_Reference_To (DT_Ptr, Loc),
+ Node2 => Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To (Node (AI), Loc)),
+ Node3 => Make_Integer_Literal (Loc, Default_Prim_Op_Count))));
+
+ Next_Elmt (AI);
+ end loop;
+
+ return Result;
+ end Init_Predefined_Interface_Primitives;
+
-------------
-- Make_DT --
-------------
-- Calculate the number of entries required in the table of interfaces
Num_Ifaces := 0;
- AI := First_Elmt (Abstract_Interfaces (Typ_Copy));
-
+ AI := First_Elmt (Abstract_Interfaces (Typ_Copy));
while Present (AI) loop
Num_Ifaces := Num_Ifaces + 1;
Next_Elmt (AI);
begin
I_Depth := 0;
-
loop
P := Etype (Parent_Type);
end loop;
end;
- TSD_Num_Entries := I_Depth + Num_Ifaces + 1;
Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ)));
+ -- Ada 2005 (AI-345): The size of the TSD is increased to accomodate
+ -- the two tables used for dispatching in asynchronous, conditional
+ -- and timed selects. The tables are solely generated for limited
+ -- types that implement a limited interface.
+
+ if Ada_Version >= Ada_05
+ and then not Is_Interface (Typ)
+ and then not Is_Abstract (Typ)
+ and then not Is_Controlled (Typ)
+ and then Implements_Limited_Interface (Typ)
+ then
+ TSD_Num_Entries := I_Depth + Num_Ifaces + 1 +
+ 2 * (Nb_Prim - Default_Prim_Op_Count);
+ else
+ TSD_Num_Entries := I_Depth + Num_Ifaces + 1;
+ end if;
+
-- ----------------------------------------------------------------
-- Dispatch table and related entities are allocated statically
-- Generate code to define the boolean that controls registration, in
-- order to avoid multiple registrations for tagged types defined in
- -- multiple-called scopes
+ -- multiple-called scopes.
Append_To (Result,
Make_Object_Declaration (Loc,
-- Generate code to create the storage for the type specific data object
-- with enough space to store the tags of the ancestors plus the tags
- -- of all the implemented interfaces (as described in a-tags.adb)
+ -- of all the implemented interfaces (as described in a-tags.adb).
--
-- TSD: Storage_Array
-- (1..TSD_Prologue_Size+TSD_Num_Entries*TSD_Entry_Size);
(Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc);
end if;
- -- Generate: Inherit_DT (parent'tag, DT_Ptr, nb_prim of parent);
-
- Append_To (Elab_Code,
- Make_DT_Access_Action (Typ,
- Action => Inherit_DT,
- Args => New_List (
- Node1 => Old_Tag1,
- Node2 => New_Reference_To (DT_Ptr, Loc),
- Node3 => Make_Integer_Literal (Loc,
- DT_Entry_Count (First_Tag_Component (Etype (Typ)))))));
+ if Typ /= Etype (Typ)
+ and then not Is_Interface (Typ)
+ and then not Is_Interface (Etype (Typ))
+ then
+ -- Generate: Inherit_DT (parent'tag, DT_Ptr, nb_prim of parent);
- -- Inherit the secondary dispatch tables of the ancestor
+ Append_To (Elab_Code,
+ Make_DT_Access_Action (Typ,
+ Action => Inherit_DT,
+ Args => New_List (
+ Node1 => Old_Tag1,
+ Node2 => New_Reference_To (DT_Ptr, Loc),
+ Node3 =>
+ Make_Integer_Literal (Loc,
+ DT_Entry_Count (First_Tag_Component (Etype (Typ)))))));
- if not Is_CPP_Class (Etype (Typ)) then
- declare
- Sec_DT_Ancestor : Elmt_Id :=
- Next_Elmt (First_Elmt (Access_Disp_Table (Etype (Typ))));
- Sec_DT_Typ : Elmt_Id :=
- Next_Elmt (First_Elmt (Access_Disp_Table (Typ)));
+ -- Inherit the secondary dispatch tables of the ancestor
- procedure Copy_Secondary_DTs (Typ : Entity_Id);
- -- ??? comment required
+ if not Is_CPP_Class (Etype (Typ)) then
+ declare
+ Sec_DT_Ancestor : Elmt_Id :=
+ Next_Elmt
+ (First_Elmt
+ (Access_Disp_Table (Etype (Typ))));
+ Sec_DT_Typ : Elmt_Id :=
+ Next_Elmt
+ (First_Elmt
+ (Access_Disp_Table (Typ)));
+
+ procedure Copy_Secondary_DTs (Typ : Entity_Id);
+ -- Local procedure required to climb through the ancestors and
+ -- copy the contents of all their secondary dispatch tables.
+
+ ------------------------
+ -- Copy_Secondary_DTs --
+ ------------------------
+
+ procedure Copy_Secondary_DTs (Typ : Entity_Id) is
+ E : Entity_Id;
- ------------------------
- -- Copy_Secondary_DTs --
- ------------------------
+ begin
+ if Etype (Typ) /= Typ then
+ Copy_Secondary_DTs (Etype (Typ));
+ end if;
- procedure Copy_Secondary_DTs (Typ : Entity_Id) is
- E : Entity_Id;
+ if Present (Abstract_Interfaces (Typ))
+ and then not Is_Empty_Elmt_List
+ (Abstract_Interfaces (Typ))
+ then
+ E := First_Entity (Typ);
+ while Present (E)
+ and then Present (Node (Sec_DT_Ancestor))
+ loop
+ if Is_Tag (E) and then Chars (E) /= Name_uTag then
+ Append_To (Elab_Code,
+ Make_DT_Access_Action (Typ,
+ Action => Inherit_DT,
+ Args => New_List (
+ Node1 => Unchecked_Convert_To
+ (RTE (RE_Tag),
+ New_Reference_To
+ (Node (Sec_DT_Ancestor), Loc)),
+ Node2 => Unchecked_Convert_To
+ (RTE (RE_Tag),
+ New_Reference_To
+ (Node (Sec_DT_Typ), Loc)),
+ Node3 => Make_Integer_Literal (Loc,
+ DT_Entry_Count (E)))));
+
+ Next_Elmt (Sec_DT_Ancestor);
+ Next_Elmt (Sec_DT_Typ);
+ end if;
+
+ Next_Entity (E);
+ end loop;
+ end if;
+ end Copy_Secondary_DTs;
begin
- if Etype (Typ) /= Typ then
- Copy_Secondary_DTs (Etype (Typ));
+ if Present (Node (Sec_DT_Ancestor)) then
+ Copy_Secondary_DTs (Typ);
end if;
-
- if Present (Abstract_Interfaces (Typ))
- and then not Is_Empty_Elmt_List
- (Abstract_Interfaces (Typ))
- then
- E := First_Entity (Typ);
-
- while Present (E)
- and then Present (Node (Sec_DT_Ancestor))
- loop
- if Is_Tag (E) and then Chars (E) /= Name_uTag then
- Append_To (Elab_Code,
- Make_DT_Access_Action (Typ,
- Action => Inherit_DT,
- Args => New_List (
- Node1 => Unchecked_Convert_To
- (RTE (RE_Tag),
- New_Reference_To
- (Node (Sec_DT_Ancestor), Loc)),
- Node2 => Unchecked_Convert_To
- (RTE (RE_Tag),
- New_Reference_To
- (Node (Sec_DT_Typ), Loc)),
- Node3 => Make_Integer_Literal (Loc,
- DT_Entry_Count (E)))));
-
- Next_Elmt (Sec_DT_Ancestor);
- Next_Elmt (Sec_DT_Typ);
- end if;
-
- Next_Entity (E);
- end loop;
- end if;
- end Copy_Secondary_DTs;
-
- begin
- if Present (Node (Sec_DT_Ancestor)) then
- Copy_Secondary_DTs (Typ);
- end if;
- end;
+ end;
+ end if;
end if;
- -- Generate: Inherit_TSD (parent'tag, DT_Ptr);
+ -- Generate:
+ -- Inherit_TSD (parent'tag, DT_Ptr);
Append_To (Elab_Code,
Make_DT_Access_Action (Typ,
end if;
end Make_DT_Access_Action;
+ ----------------------------------------
+ -- Make_Disp_Asynchronous_Select_Body --
+ ----------------------------------------
+
+ function Make_Disp_Asynchronous_Select_Body
+ (Typ : Entity_Id) return Node_Id
+ is
+ Conc_Typ : Entity_Id := Empty;
+ Decls : constant List_Id := New_List;
+ DT_Ptr : Entity_Id;
+ DT_Ptr_Typ : Entity_Id;
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Stmts : constant List_Id := New_List;
+
+ begin
+ if Is_Concurrent_Record_Type (Typ) then
+ Conc_Typ := Corresponding_Concurrent_Type (Typ);
+ end if;
+
+ -- Typ may be a derived type, climb the derivation chain in order to
+ -- find the root.
+
+ DT_Ptr_Typ := Typ;
+ while Present (Parent_Subtype (DT_Ptr_Typ)) loop
+ DT_Ptr_Typ := Parent_Subtype (DT_Ptr_Typ);
+ end loop;
+
+ DT_Ptr := Node (First_Elmt (Access_Disp_Table (DT_Ptr_Typ)));
+
+ if Present (Conc_Typ) then
+
+ -- Generate:
+ -- I : Integer := get_entry_index (tag! (<type>VP), S);
+
+ -- where I will be used to capture the entry index of the primitive
+ -- wrapper at position S.
+
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uI),
+ Object_Definition =>
+ New_Reference_To (Standard_Integer, Loc),
+ Expression =>
+ Make_DT_Access_Action (Typ,
+ Action =>
+ Get_Entry_Index,
+ Args =>
+ New_List (
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To (DT_Ptr, Loc)),
+ Make_Identifier (Loc, Name_uS)))));
+
+ if Ekind (Conc_Typ) = E_Protected_Type then
+
+ -- Generate:
+ -- Protected_Entry_Call (
+ -- T._object'access,
+ -- protected_entry_index! (I),
+ -- P,
+ -- Asynchronous_Call,
+ -- B);
+
+ -- where T is the protected object, I is the entry index, P are
+ -- the wrapped parameters and B is the name of the communication
+ -- block.
+
+ Append_To (Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Protected_Entry_Call), Loc),
+ Parameter_Associations =>
+ New_List (
+
+ Make_Attribute_Reference (Loc, -- T._object'access
+ Attribute_Name =>
+ Name_Unchecked_Access,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Make_Identifier (Loc, Name_uT),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_uObject))),
+
+ Make_Unchecked_Type_Conversion (Loc, -- entry index
+ Subtype_Mark =>
+ New_Reference_To (RTE (RE_Protected_Entry_Index), Loc),
+ Expression =>
+ Make_Identifier (Loc, Name_uI)),
+
+ Make_Identifier (Loc, Name_uP), -- parameter block
+ New_Reference_To ( -- Asynchronous_Call
+ RTE (RE_Asynchronous_Call), Loc),
+ Make_Identifier (Loc, Name_uB)))); -- comm block
+ else
+ pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
+
+ -- Generate:
+ -- Protected_Entry_Call (
+ -- T._task_id,
+ -- task_entry_index! (I),
+ -- P,
+ -- Conditional_Call,
+ -- F);
+
+ -- where T is the task object, I is the entry index, P are the
+ -- wrapped parameters and F is the status flag.
+
+ Append_To (Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
+ Parameter_Associations =>
+ New_List (
+
+ Make_Selected_Component (Loc, -- T._task_id
+ Prefix =>
+ Make_Identifier (Loc, Name_uT),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_uTask_Id)),
+
+ Make_Unchecked_Type_Conversion (Loc, -- entry index
+ Subtype_Mark =>
+ New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
+ Expression =>
+ Make_Identifier (Loc, Name_uI)),
+
+ Make_Identifier (Loc, Name_uP), -- parameter block
+ New_Reference_To ( -- Asynchronous_Call
+ RTE (RE_Asynchronous_Call), Loc),
+ Make_Identifier (Loc, Name_uF)))); -- status flag
+ end if;
+
+ -- Null implementation for limited tagged types
+
+ else
+ Append_To (Stmts,
+ Make_Null_Statement (Loc));
+ end if;
+
+ return
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Disp_Asynchronous_Select_Spec (Typ),
+ Declarations =>
+ Decls,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc, Stmts));
+ end Make_Disp_Asynchronous_Select_Body;
+
+ ----------------------------------------
+ -- Make_Disp_Asynchronous_Select_Spec --
+ ----------------------------------------
+
+ function Make_Disp_Asynchronous_Select_Spec
+ (Typ : Entity_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Params : constant List_Id := New_List;
+
+ begin
+ -- "T" - Object parameter
+ -- "S" - Primitive operation slot
+ -- "P" - Wrapped parameters
+ -- "B" - Communication block
+ -- "F" - Status flag
+
+ SEU.Build_T (Loc, Typ, Params);
+ SEU.Build_S (Loc, Params);
+ SEU.Build_P (Loc, Params);
+ SEU.Build_B (Loc, Params);
+ SEU.Build_F (Loc, Params);
+
+ return
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name =>
+ Make_Defining_Identifier (Loc, Name_uDisp_Asynchronous_Select),
+ Parameter_Specifications =>
+ Params);
+ end Make_Disp_Asynchronous_Select_Spec;
+
+ ---------------------------------------
+ -- Make_Disp_Conditional_Select_Body --
+ ---------------------------------------
+
+ function Make_Disp_Conditional_Select_Body
+ (Typ : Entity_Id) return Node_Id
+ is
+ Blk_Nam : Entity_Id;
+ Conc_Typ : Entity_Id := Empty;
+ Decls : constant List_Id := New_List;
+ DT_Ptr : Entity_Id;
+ DT_Ptr_Typ : Entity_Id;
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Stmts : constant List_Id := New_List;
+
+ begin
+ if Is_Concurrent_Record_Type (Typ) then
+ Conc_Typ := Corresponding_Concurrent_Type (Typ);
+ end if;
+
+ -- Typ may be a derived type, climb the derivation chain in order to
+ -- find the root.
+
+ DT_Ptr_Typ := Typ;
+ while Present (Parent_Subtype (DT_Ptr_Typ)) loop
+ DT_Ptr_Typ := Parent_Subtype (DT_Ptr_Typ);
+ end loop;
+
+ DT_Ptr := Node (First_Elmt (Access_Disp_Table (DT_Ptr_Typ)));
+
+ if Present (Conc_Typ) then
+ -- Generate:
+ -- I : Integer;
+
+ -- where I will be used to capture the entry index of the primitive
+ -- wrapper at position S.
+
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uI),
+ Object_Definition =>
+ New_Reference_To (Standard_Integer, Loc)));
+ end if;
+
+ -- Generate:
+ -- C := get_prim_op_kind (tag! (<type>VP), S);
+
+ -- if C = POK_Procedure
+ -- or else C = POK_Protected_Procedure
+ -- or else C = POK_Task_Procedure;
+ -- then
+ -- F := True;
+ -- return;
+ -- end if;
+
+ SEU.Build_Common_Dispatching_Select_Statements (Loc, Typ, Stmts);
+
+ if Present (Conc_Typ) then
+
+ -- Generate:
+ -- Bnn : Communication_Block;
+
+ -- where Bnn is the name of the communication block used in
+ -- the call to Protected_Entry_Call.
+
+ Blk_Nam := Make_Defining_Identifier (Loc, New_Internal_Name ('B'));
+
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Blk_Nam,
+ Object_Definition =>
+ New_Reference_To (RTE (RE_Communication_Block), Loc)));
+
+ -- Generate:
+ -- I := get_entry_index (tag! (<type>VP), S);
+
+ -- where I is the entry index and S is the dispatch table slot.
+
+ Append_To (Stmts,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Identifier (Loc, Name_uI),
+ Expression =>
+ Make_DT_Access_Action (Typ,
+ Action =>
+ Get_Entry_Index,
+ Args =>
+ New_List (
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To (DT_Ptr, Loc)),
+ Make_Identifier (Loc, Name_uS)))));
+
+ if Ekind (Conc_Typ) = E_Protected_Type then
+
+ -- Generate:
+ -- Protected_Entry_Call (
+ -- T._object'access,
+ -- protected_entry_index! (I),
+ -- P,
+ -- Conditional_Call,
+ -- Bnn);
+
+ -- where T is the protected object, I is the entry index, P are
+ -- the wrapped parameters and Bnn is the name of the communication
+ -- block.
+
+ Append_To (Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Protected_Entry_Call), Loc),
+ Parameter_Associations =>
+ New_List (
+
+ Make_Attribute_Reference (Loc, -- T._object'access
+ Attribute_Name =>
+ Name_Unchecked_Access,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Make_Identifier (Loc, Name_uT),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_uObject))),
+
+ Make_Unchecked_Type_Conversion (Loc, -- entry index
+ Subtype_Mark =>
+ New_Reference_To (RTE (RE_Protected_Entry_Index), Loc),
+ Expression =>
+ Make_Identifier (Loc, Name_uI)),
+
+ Make_Identifier (Loc, Name_uP), -- parameter block
+ New_Reference_To ( -- Conditional_Call
+ RTE (RE_Conditional_Call), Loc),
+ New_Reference_To ( -- Bnn
+ Blk_Nam, Loc))));
+
+ -- Generate:
+ -- F := not Cancelled (Bnn);
+
+ -- where F is the success flag. The status of Cancelled is negated
+ -- in order to match the behaviour of the version for task types.
+
+ Append_To (Stmts,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Identifier (Loc, Name_uF),
+ Expression =>
+ Make_Op_Not (Loc,
+ Right_Opnd =>
+ Make_Function_Call (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Cancelled), Loc),
+ Parameter_Associations =>
+ New_List (
+ New_Reference_To (Blk_Nam, Loc))))));
+ else
+ pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
+
+ -- Generate:
+ -- Protected_Entry_Call (
+ -- T._task_id,
+ -- task_entry_index! (I),
+ -- P,
+ -- Conditional_Call,
+ -- F);
+
+ -- where T is the task object, I is the entry index, P are the
+ -- wrapped parameters and F is the status flag.
+
+ Append_To (Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
+ Parameter_Associations =>
+ New_List (
+
+ Make_Selected_Component (Loc, -- T._task_id
+ Prefix =>
+ Make_Identifier (Loc, Name_uT),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_uTask_Id)),
+
+ Make_Unchecked_Type_Conversion (Loc, -- entry index
+ Subtype_Mark =>
+ New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
+ Expression =>
+ Make_Identifier (Loc, Name_uI)),
+
+ Make_Identifier (Loc, Name_uP), -- parameter block
+ New_Reference_To ( -- Conditional_Call
+ RTE (RE_Conditional_Call), Loc),
+ Make_Identifier (Loc, Name_uF)))); -- status flag
+ end if;
+
+ -- Null implementation for limited tagged types
+
+ else
+ Append_To (Stmts,
+ Make_Null_Statement (Loc));
+ end if;
+
+ return
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Disp_Conditional_Select_Spec (Typ),
+ Declarations =>
+ Decls,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc, Stmts));
+ end Make_Disp_Conditional_Select_Body;
+
+ ---------------------------------------
+ -- Make_Disp_Conditional_Select_Spec --
+ ---------------------------------------
+
+ function Make_Disp_Conditional_Select_Spec
+ (Typ : Entity_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Params : constant List_Id := New_List;
+
+ begin
+ -- "T" - Object parameter
+ -- "S" - Primitive operation slot
+ -- "P" - Wrapped parameters
+ -- "C" - Call kind
+ -- "F" - Status flag
+
+ SEU.Build_T (Loc, Typ, Params);
+ SEU.Build_S (Loc, Params);
+ SEU.Build_P (Loc, Params);
+ SEU.Build_C (Loc, Params);
+ SEU.Build_F (Loc, Params);
+
+ return
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name =>
+ Make_Defining_Identifier (Loc, Name_uDisp_Conditional_Select),
+ Parameter_Specifications =>
+ Params);
+ end Make_Disp_Conditional_Select_Spec;
+
+ -------------------------------------
+ -- Make_Disp_Get_Prim_Op_Kind_Body --
+ -------------------------------------
+
+ function Make_Disp_Get_Prim_Op_Kind_Body
+ (Typ : Entity_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Typ);
+ DT_Ptr : Entity_Id;
+ DT_Ptr_Typ : Entity_Id;
+
+ begin
+ -- Typ may be a derived type, climb the derivation chain in order to
+ -- find the root.
+
+ DT_Ptr_Typ := Typ;
+ while Present (Parent_Subtype (DT_Ptr_Typ)) loop
+ DT_Ptr_Typ := Parent_Subtype (DT_Ptr_Typ);
+ end loop;
+
+ DT_Ptr := Node (First_Elmt (Access_Disp_Table (DT_Ptr_Typ)));
+
+ -- Generate:
+ -- C := get_prim_op_kind (tag! (<type>VP), S);
+
+ -- where C is the out parameter capturing the call kind and S is the
+ -- dispatch table slot number.
+
+ return
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Disp_Get_Prim_Op_Kind_Spec (Typ),
+ Declarations =>
+ No_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ New_List (
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Identifier (Loc, Name_uC),
+ Expression =>
+ Make_DT_Access_Action (Typ,
+ Action =>
+ Get_Prim_Op_Kind,
+ Args =>
+ New_List (
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To (DT_Ptr, Loc)),
+ Make_Identifier (Loc, Name_uS)))))));
+ end Make_Disp_Get_Prim_Op_Kind_Body;
+
+ -------------------------------------
+ -- Make_Disp_Get_Prim_Op_Kind_Spec --
+ -------------------------------------
+
+ function Make_Disp_Get_Prim_Op_Kind_Spec
+ (Typ : Entity_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Params : constant List_Id := New_List;
+
+ begin
+ -- "T" - Object parameter
+ -- "S" - Primitive operation slot
+ -- "C" - Call kind
+
+ SEU.Build_T (Loc, Typ, Params);
+ SEU.Build_S (Loc, Params);
+ SEU.Build_C (Loc, Params);
+
+ return
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name =>
+ Make_Defining_Identifier (Loc, Name_uDisp_Get_Prim_Op_Kind),
+ Parameter_Specifications =>
+ Params);
+ end Make_Disp_Get_Prim_Op_Kind_Spec;
+
+ -----------------------------
+ -- Make_Disp_Select_Tables --
+ -----------------------------
+
+ function Make_Disp_Select_Tables
+ (Typ : Entity_Id) return List_Id
+ is
+ Assignments : constant List_Id := New_List;
+ DT_Ptr : Entity_Id;
+ DT_Ptr_Typ : Entity_Id;
+ Index : Uint := Uint_1;
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Prim : Entity_Id;
+ Prim_Als : Entity_Id;
+ Prim_Elmt : Elmt_Id;
+ Prim_Pos : Uint;
+
+ begin
+ pragma Assert (Present (Primitive_Operations (Typ)));
+
+ -- Typ may be a derived type, climb the derivation chain in order to
+ -- find the root.
+
+ DT_Ptr_Typ := Typ;
+ while Present (Parent_Subtype (DT_Ptr_Typ)) loop
+ DT_Ptr_Typ := Parent_Subtype (DT_Ptr_Typ);
+ end loop;
+
+ DT_Ptr := Node (First_Elmt (Access_Disp_Table (DT_Ptr_Typ)));
+
+ Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
+ while Present (Prim_Elmt) loop
+ Prim := Node (Prim_Elmt);
+
+ -- Retrieve the root of the alias chain
+
+ if Present (Alias (Prim)) then
+ Prim_Als := Prim;
+ while Present (Alias (Prim_Als)) loop
+ Prim_Als := Alias (Prim_Als);
+ end loop;
+ else
+ Prim_Als := Empty;
+ end if;
+
+ -- We either have a procedure or a wrapper. Set the primitive
+ -- operation kind for both cases and set the entry index for
+ -- wrappers.
+
+ if Ekind (Prim) = E_Procedure
+ and then Present (Prim_Als)
+ and then Is_Primitive_Wrapper (Prim_Als)
+ then
+ Prim_Pos := DT_Position (Prim);
+
+ -- Generate:
+ -- set_prim_op_kind (<tag>, <position>, <kind>);
+
+ Append_To (Assignments,
+ Make_DT_Access_Action (Typ,
+ Action =>
+ Set_Prim_Op_Kind,
+ Args =>
+ New_List (
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To (DT_Ptr, Loc)),
+ Make_Integer_Literal (Loc, Prim_Pos),
+ Prim_Op_Kind (Prim, Typ))));
+
+ -- The wrapped entity of the alias is an entry
+
+ if Ekind (Wrapped_Entity (Prim_Als)) = E_Entry then
+ -- Generate:
+ -- set_entry_index (<tag>, <position>, <index>);
+
+ Append_To (Assignments,
+ Make_DT_Access_Action (Typ,
+ Action =>
+ Set_Entry_Index,
+ Args =>
+ New_List (
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To (DT_Ptr, Loc)),
+ Make_Integer_Literal (Loc, Prim_Pos),
+ Make_Integer_Literal (Loc, Index))));
+
+ Index := Index + 1;
+ end if;
+ end if;
+
+ Next_Elmt (Prim_Elmt);
+ end loop;
+
+ return Assignments;
+ end Make_Disp_Select_Tables;
+
+ ---------------------------------
+ -- Make_Disp_Timed_Select_Body --
+ ---------------------------------
+
+ function Make_Disp_Timed_Select_Body
+ (Typ : Entity_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Conc_Typ : Entity_Id := Empty;
+ Decls : constant List_Id := New_List;
+ DT_Ptr : Entity_Id;
+ DT_Ptr_Typ : Entity_Id;
+ Stmts : constant List_Id := New_List;
+
+ begin
+ if Is_Concurrent_Record_Type (Typ) then
+ Conc_Typ := Corresponding_Concurrent_Type (Typ);
+ end if;
+
+ -- Typ may be a derived type, climb the derivation chain in order to
+ -- find the root.
+
+ DT_Ptr_Typ := Typ;
+ while Present (Parent_Subtype (DT_Ptr_Typ)) loop
+ DT_Ptr_Typ := Parent_Subtype (DT_Ptr_Typ);
+ end loop;
+
+ DT_Ptr := Node (First_Elmt (Access_Disp_Table (DT_Ptr_Typ)));
+
+ if Present (Conc_Typ) then
+
+ -- Generate:
+ -- I : Integer;
+
+ -- where I will be used to capture the entry index of the primitive
+ -- wrapper at position S.
+
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uI),
+ Object_Definition =>
+ New_Reference_To (Standard_Integer, Loc)));
+ end if;
+
+ -- Generate:
+ -- C := get_prim_op_kind (tag! (<type>VP), S);
+
+ -- if C = POK_Procedure
+ -- or else C = POK_Protected_Procedure
+ -- or else C = POK_Task_Procedure;
+ -- then
+ -- F := True;
+ -- return;
+ -- end if;
+
+ SEU.Build_Common_Dispatching_Select_Statements (Loc, Typ, Stmts);
+
+ if Present (Conc_Typ) then
+
+ -- Generate:
+ -- I := get_entry_index (tag! (<type>VP), S);
+
+ -- where I is the entry index and S is the dispatch table slot.
+
+ Append_To (Stmts,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Identifier (Loc, Name_uI),
+ Expression =>
+ Make_DT_Access_Action (Typ,
+ Action =>
+ Get_Entry_Index,
+ Args =>
+ New_List (
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To (DT_Ptr, Loc)),
+ Make_Identifier (Loc, Name_uS)))));
+
+ if Ekind (Conc_Typ) = E_Protected_Type then
+
+ -- Generate:
+ -- Timed_Protected_Entry_Call (
+ -- T._object'access,
+ -- protected_entry_index! (I),
+ -- P,
+ -- D,
+ -- M,
+ -- F);
+
+ -- where T is the protected object, I is the entry index, P are
+ -- the wrapped parameters, D is the delay amount, M is the delay
+ -- mode and F is the status flag.
+
+ Append_To (Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Timed_Protected_Entry_Call), Loc),
+ Parameter_Associations =>
+ New_List (
+
+ Make_Attribute_Reference (Loc, -- T._object'access
+ Attribute_Name =>
+ Name_Unchecked_Access,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Make_Identifier (Loc, Name_uT),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_uObject))),
+
+ Make_Unchecked_Type_Conversion (Loc, -- entry index
+ Subtype_Mark =>
+ New_Reference_To (RTE (RE_Protected_Entry_Index), Loc),
+ Expression =>
+ Make_Identifier (Loc, Name_uI)),
+
+ Make_Identifier (Loc, Name_uP), -- parameter block
+ Make_Identifier (Loc, Name_uD), -- delay
+ Make_Identifier (Loc, Name_uM), -- delay mode
+ Make_Identifier (Loc, Name_uF)))); -- status flag
+
+ else
+ pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
+
+ -- Generate:
+ -- Timed_Task_Entry_Call (
+ -- T._task_id,
+ -- task_entry_index! (I),
+ -- P,
+ -- D,
+ -- M,
+ -- F);
+
+ -- where T is the task object, I is the entry index, P are the
+ -- wrapped parameters, D is the delay amount, M is the delay
+ -- mode and F is the status flag.
+
+ Append_To (Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Timed_Task_Entry_Call), Loc),
+ Parameter_Associations =>
+ New_List (
+
+ Make_Selected_Component (Loc, -- T._task_id
+ Prefix =>
+ Make_Identifier (Loc, Name_uT),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_uTask_Id)),
+
+ Make_Unchecked_Type_Conversion (Loc, -- entry index
+ Subtype_Mark =>
+ New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
+ Expression =>
+ Make_Identifier (Loc, Name_uI)),
+
+ Make_Identifier (Loc, Name_uP), -- parameter block
+ Make_Identifier (Loc, Name_uD), -- delay
+ Make_Identifier (Loc, Name_uM), -- delay mode
+ Make_Identifier (Loc, Name_uF)))); -- status flag
+ end if;
+
+ -- Null implementation for limited tagged types
+
+ else
+ Append_To (Stmts,
+ Make_Null_Statement (Loc));
+ end if;
+
+ return
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Disp_Timed_Select_Spec (Typ),
+ Declarations =>
+ Decls,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc, Stmts));
+ end Make_Disp_Timed_Select_Body;
+
+ ---------------------------------
+ -- Make_Disp_Timed_Select_Spec --
+ ---------------------------------
+
+ function Make_Disp_Timed_Select_Spec
+ (Typ : Entity_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Params : constant List_Id := New_List;
+
+ begin
+ -- "T" - Object parameter
+ -- "S" - Primitive operation slot
+ -- "P" - Wrapped parameters
+ -- "D" - Delay
+ -- "M" - Delay Mode
+ -- "C" - Call kind
+ -- "F" - Status flag
+
+ SEU.Build_T (Loc, Typ, Params);
+ SEU.Build_S (Loc, Params);
+ SEU.Build_P (Loc, Params);
+
+ Append_To (Params,
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uD),
+ Parameter_Type =>
+ New_Reference_To (Standard_Duration, Loc)));
+
+ Append_To (Params,
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uM),
+ Parameter_Type =>
+ New_Reference_To (Standard_Integer, Loc)));
+
+ SEU.Build_C (Loc, Params);
+ SEU.Build_F (Loc, Params);
+
+ return
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name =>
+ Make_Defining_Identifier (Loc, Name_uDisp_Timed_Select),
+ Parameter_Specifications =>
+ Params);
+ end Make_Disp_Timed_Select_Spec;
+
-----------------------------------
-- Original_View_In_Visible_Part --
-----------------------------------
Visible_Declarations (Specification (Unit_Declaration_Node (Scop)));
end Original_View_In_Visible_Part;
+ ------------------
+ -- Prim_Op_Kind --
+ ------------------
+
+ function Prim_Op_Kind
+ (Prim : Entity_Id;
+ Typ : Entity_Id) return Node_Id
+ is
+ Full_Typ : Entity_Id := Typ;
+ Loc : constant Source_Ptr := Sloc (Prim);
+ Prim_Op : Entity_Id := Prim;
+
+ begin
+ -- Retrieve the original primitive operation
+
+ while Present (Alias (Prim_Op)) loop
+ Prim_Op := Alias (Prim_Op);
+ end loop;
+
+ if Ekind (Typ) = E_Record_Type
+ and then Present (Corresponding_Concurrent_Type (Typ))
+ then
+ Full_Typ := Corresponding_Concurrent_Type (Typ);
+ end if;
+
+ if Ekind (Prim_Op) = E_Function then
+
+ -- Protected function
+
+ if Ekind (Full_Typ) = E_Protected_Type then
+ return New_Reference_To (RTE (RE_POK_Protected_Function), Loc);
+
+ -- Regular function
+
+ else
+ return New_Reference_To (RTE (RE_POK_Function), Loc);
+ end if;
+
+ else
+ pragma Assert (Ekind (Prim_Op) = E_Procedure);
+
+ if Ekind (Full_Typ) = E_Protected_Type then
+
+ -- Protected entry
+
+ if Is_Primitive_Wrapper (Prim_Op)
+ and then Ekind (Wrapped_Entity (Prim_Op)) = E_Entry
+ then
+ return New_Reference_To (RTE (RE_POK_Protected_Entry), Loc);
+
+ -- Protected procedure
+
+ else
+ return New_Reference_To (RTE (RE_POK_Protected_Procedure), Loc);
+ end if;
+
+ elsif Ekind (Full_Typ) = E_Task_Type then
+
+ -- Task entry
+
+ if Is_Primitive_Wrapper (Prim_Op)
+ and then Ekind (Wrapped_Entity (Prim_Op)) = E_Entry
+ then
+ return New_Reference_To (RTE (RE_POK_Task_Entry), Loc);
+
+ -- Task "procedure". These are the internally Expander-generated
+ -- procedures (task body for instance).
+
+ else
+ return New_Reference_To (RTE (RE_POK_Task_Procedure), Loc);
+ end if;
+
+ -- Regular procedure
+
+ else
+ return New_Reference_To (RTE (RE_POK_Procedure), Loc);
+ end if;
+ end if;
+ end Prim_Op_Kind;
+
-------------------------
-- Set_All_DT_Position --
-------------------------
procedure Validate_Position (Prim : Entity_Id) is
Prim_Elmt : Elmt_Id;
+
begin
Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
while Present (Prim_Elmt)
null;
elsif DT_Position (Node (Prim_Elmt)) = DT_Position (Prim) then
- raise Program_Error;
+
+ -- Handle aliased subprograms
+
+ declare
+ Op_1 : Entity_Id;
+ Op_2 : Entity_Id;
+
+ begin
+ Op_1 := Node (Prim_Elmt);
+ loop
+ if Present (Overridden_Operation (Op_1)) then
+ Op_1 := Overridden_Operation (Op_1);
+ elsif Present (Alias (Op_1)) then
+ Op_1 := Alias (Op_1);
+ else
+ exit;
+ end if;
+ end loop;
+
+ Op_2 := Prim;
+ loop
+ if Present (Overridden_Operation (Op_2)) then
+ Op_2 := Overridden_Operation (Op_2);
+ elsif Present (Alias (Op_2)) then
+ Op_2 := Alias (Op_2);
+ else
+ exit;
+ end if;
+ end loop;
+
+ if Op_1 /= Op_2 then
+ raise Program_Error;
+ end if;
+ end;
end if;
Next_Elmt (Prim_Elmt);
-- Get the slot from the parent subprogram if any
declare
- H : Entity_Id := Homonym (Prim);
+ H : Entity_Id;
begin
+ H := Homonym (Prim);
while Present (H) loop
if Present (DTC_Entity (H))
and then Root_Type (Scope (DTC_Entity (H))) = Root_Typ
-- Check that the declared size of the Vtable is bigger or equal
-- than the number of primitive operations (if bigger it means that
-- some of the c++ virtual functions were not imported, that is
- -- allowed)
+ -- allowed).
if DT_Entry_Count (The_Tag) = No_Uint
or else not Is_CPP_Class (Typ)
end if;
-- Check that Positions are not duplicate nor outside the range of
- -- the Vtable
+ -- the Vtable.
declare
Size : constant Int := UI_To_Int (DT_Entry_Count (The_Tag));
end loop;
end;
+ -- Generate listing showing the contents of the dispatch tables
+
+ if Debug_Flag_ZZ then
+ Write_DT (Typ);
+ end if;
+
-- For regular Ada tagged types, just set the DT_Position for
-- each primitive operation. Perform some sanity checks to avoid
-- to build completely inconsistant dispatch tables.
-- Note that the _Size primitive is always set at position 1 in order
-- to comply with the needs of Ada.Tags.Parent_Size (see documentation
- -- in a-tags.ad?)
+ -- in Ada.Tags).
else
-- First stage: Set the DTC entity of all the primitive operations
Prim_Elmt := First_Prim;
Count_Prim := 0;
-
while Present (Prim_Elmt) loop
Count_Prim := Count_Prim + 1;
Prim := Node (Prim_Elmt);
end loop;
declare
- Fixed_Prim : array (Int range 0 .. 10 + Parent_EC + Count_Prim)
- of Boolean := (others => False);
- E : Entity_Id;
+ Fixed_Prim : array (Int range 0 .. Default_Prim_Op_Count +
+ Parent_EC + Count_Prim)
+ of Boolean := (others => False);
+
+ E : Entity_Id;
begin
-- Second stage: Register fixed entries
- Nb_Prim := 10;
+ Nb_Prim := Default_Prim_Op_Count;
Prim_Elmt := First_Prim;
-
while Present (Prim_Elmt) loop
Prim := Node (Prim_Elmt);
-- traversing the chain. This is required to properly
-- handling renamed primitives
- if Present (Alias (E)) then
- while Present (Alias (E)) loop
- E := Alias (E);
- Fixed_Prim (UI_To_Int (DT_Position (E))) := True;
- end loop;
- end if;
+ while Present (Alias (E)) loop
+ E := Alias (E);
+ Fixed_Prim (UI_To_Int (DT_Position (E))) := True;
+ end loop;
end if;
Next_Elmt (Prim_Elmt);
Next_Elmt (Prim_Elmt);
end loop;
+ -- Generate listing showing the contents of the dispatch tables.
+ -- This action is done before some further static checks because
+ -- in case of critical errors caused by a wrong dispatch table
+ -- we need to see the contents of such table.
+
+ if Debug_Flag_ZZ then
+ Write_DT (Typ);
+ end if;
+
-- Final stage: Ensure that the table is correct plus some further
-- verifications concerning the primitives.
Prim_Elmt := First_Prim;
DT_Length := 0;
-
while Present (Prim_Elmt) loop
Prim := Node (Prim_Elmt);
null;
end if;
end if;
-
- if Debug_Flag_ZZ then
- Write_DT (Typ);
- end if;
end Set_All_DT_Position;
-----------------------------
if not (Typ in First_Node_Id .. Last_Node_Id)
or else not Is_Tagged_Type (Typ)
then
- Write_Str ("wrong usage: write_dt must be used with tagged types");
+ Write_Str ("wrong usage: Write_DT must be used with tagged types");
Write_Eol;
return;
end if;
with Types; use Types;
package Exp_Disp is
+ -- Number of predefined primitive operations added by the Expander
+ -- for a tagged type. If more predefined primitive operations are
+ -- added, the following items must be changed:
+
+ -- Ada.Tags.Defailt_Prim_Op_Count - indirect use
+ -- Exp_Disp.Default_Prim_Op_Position - indirect use
+ -- Exp_Disp.Set_All_DT_Position - direct use
+
+ Default_Prim_Op_Count : constant Int := 14;
+
type DT_Access_Action is
(CW_Membership,
IW_Membership,
DT_Entry_Size,
DT_Prologue_Size,
Get_Access_Level,
+ Get_Entry_Index,
Get_External_Tag,
Get_Prim_Op_Address,
+ Get_Prim_Op_Kind,
Get_RC_Offset,
Get_Remotely_Callable,
Inherit_DT,
Register_Interface_Tag,
Register_Tag,
Set_Access_Level,
+ Set_Entry_Index,
Set_Expanded_Name,
Set_External_Tag,
Set_Prim_Op_Address,
+ Set_Prim_Op_Kind,
Set_RC_Offset,
Set_Remotely_Callable,
Set_TSD,
TSD_Entry_Size,
TSD_Prologue_Size);
+ procedure Expand_Dispatching_Call (Call_Node : Node_Id);
+ -- Expand the call to the operation through the dispatch table and perform
+ -- the required tag checks when appropriate. For CPP types the call is
+ -- done through the Vtable (tag checks are not relevant)
+
+ procedure Expand_Interface_Actuals (Call_Node : Node_Id);
+ -- Ada 2005 (AI-251): Displace all the actuals corresponding to class-wide
+ -- interfaces to reference the interface tag of the actual object
+
+ procedure Expand_Interface_Conversion (N : Node_Id);
+ -- Ada 2005 (AI-251): N is a type-conversion node. Reference the base of
+ -- the object to give access to the interface tag associated with the
+ -- secondary dispatch table
+
+ function Expand_Interface_Thunk
+ (N : Node_Id;
+ Thunk_Alias : Node_Id;
+ Thunk_Id : Entity_Id;
+ Thunk_Tag : Entity_Id) return Node_Id;
+ -- Ada 2005 (AI-251): When a tagged type implements abstract interfaces we
+ -- generate additional subprograms (thunks) to have a layout compatible
+ -- with the C++ ABI. The thunk modifies the value of the first actual of
+ -- the call (that is, the pointer to the object) before transferring
+ -- control to the target function.
+
function Fill_DT_Entry
(Loc : Source_Ptr;
Prim : Entity_Id) return Node_Id;
-- the secondary dispatch table of Prim's controlling type with Thunk_Id's
-- address.
+ function Get_Remotely_Callable (Obj : Node_Id) return Node_Id;
+ -- Return an expression that holds True if the object can be transmitted
+ -- onto another partition according to E.4 (18)
+
+ function Init_Predefined_Interface_Primitives
+ (Typ : Entity_Id) return List_Id;
+ -- Ada 2005 (AI-251): Initialize the entries associated with predefined
+ -- primitives in all the secondary dispatch tables of Typ.
+
procedure Make_Abstract_Interface_DT
(AI_Tag : Entity_Id;
Acc_Disp_Tables : in out Elist_Id;
-- Expand the declarations for the Dispatch Table (or the Vtable in
-- the case of type whose ancestor is a CPP_Class)
+ function Make_Disp_Asynchronous_Select_Body
+ (Typ : Entity_Id) return Node_Id;
+ -- Ada 2005 (AI-345): Generate the body of the primitive operation of type
+ -- Typ used for dispatching in asynchronous selects.
+
+ function Make_Disp_Asynchronous_Select_Spec
+ (Typ : Entity_Id) return Node_Id;
+ -- Ada 2005 (AI-345): Generate the specification of the primitive operation
+ -- of type Typ used for dispatching in asynchronous selects.
+
+ function Make_Disp_Conditional_Select_Body
+ (Typ : Entity_Id) return Node_Id;
+ -- Ada 2005 (AI-345): Generate the body of the primitive operation of type
+ -- Typ used for dispatching in conditional selects.
+
+ function Make_Disp_Conditional_Select_Spec
+ (Typ : Entity_Id) return Node_Id;
+ -- Ada 2005 (AI-345): Generate the specification of the primitive operation
+ -- of type Typ used for dispatching in conditional selects.
+
+ function Make_Disp_Get_Prim_Op_Kind_Body
+ (Typ : Entity_Id) return Node_Id;
+ -- Ada 2005 (AI-345): Generate the body of the primitive operation of type
+ -- Typ used for retrieving the callable entity kind during dispatching in
+ -- asynchronous selects.
+
+ function Make_Disp_Get_Prim_Op_Kind_Spec
+ (Typ : Entity_Id) return Node_Id;
+ -- Ada 2005 (AI-345): Generate the specification of the primitive operation
+ -- of the type Typ use for retrieving the callable entity kind during
+ -- dispatching in asynchronous selects.
+
+ function Make_Disp_Select_Tables
+ (Typ : Entity_Id) return List_Id;
+ -- Ada 2005 (AI-345): Populate the two auxiliary tables in the TSD of Typ
+ -- used for dispatching in asynchronous, conditional and timed selects.
+ -- Generate code to set the primitive operation kinds and entry indices
+ -- of primitive operations and primitive wrappers.
+
+ function Make_Disp_Timed_Select_Body
+ (Typ : Entity_Id) return Node_Id;
+ -- Ada 2005 (AI-345): Generate the body of the primitive operation of type
+ -- Typ used for dispatching in timed selects.
+
+ function Make_Disp_Timed_Select_Spec
+ (Typ : Entity_Id) return Node_Id;
+ -- Ada 2005 (AI-345): Generate the specification of the primitive operation
+ -- of type Typ used for dispatching in timed selects.
+
procedure Set_All_DT_Position (Typ : Entity_Id);
-- Set the DT_Position field for each primitive operation. In the CPP
-- Class case check that no pragma CPP_Virtual is missing and that the
-- DT_Position are coherent
- procedure Expand_Dispatching_Call (Call_Node : Node_Id);
- -- Expand the call to the operation through the dispatch table and perform
- -- the required tag checks when appropriate. For CPP types the call is
- -- done through the Vtable (tag checks are not relevant)
-
- procedure Expand_Interface_Actuals (Call_Node : Node_Id);
- -- Ada 2005 (AI-251): Displace all the actuals corresponding to class-wide
- -- interfaces to reference the interface tag of the actual object
-
- procedure Expand_Interface_Conversion (N : Node_Id);
- -- Ada 2005 (AI-251): N is a type-conversion node. Reference the base of
- -- the object to give access to the interface tag associated with the
- -- secondary dispatch table
-
- function Expand_Interface_Thunk
- (N : Node_Id;
- Thunk_Alias : Node_Id;
- Thunk_Id : Entity_Id;
- Iface_Tag : Entity_Id) return Node_Id;
- -- Ada 2005 (AI-251): When a tagged type implements abstract interfaces we
- -- generate additional subprograms (thunks) to have a layout compatible
- -- with the C++ ABI. The thunk modifies the value of the first actual of
- -- the call (that is, the pointer to the object) before transferring
- -- control to the target function.
-
procedure Set_Default_Constructor (Typ : Entity_Id);
-- Typ is a CPP_Class type. Create the Init procedure of that type to
-- be the default constructor (i.e. the function returning this type,
-- having a pragma CPP_Constructor and no parameter)
- function Get_Remotely_Callable (Obj : Node_Id) return Node_Id;
- -- Return an expression that holds True if the object can be transmitted
- -- onto another partition according to E.4 (18)
-
procedure Write_DT (Typ : Entity_Id);
pragma Export (Ada, Write_DT);
-- Debugging procedure (to be called within gdb)
with Errout; use Errout;
with Exp_Aggr; use Exp_Aggr;
with Exp_Ch7; use Exp_Ch7;
-with Exp_Ch11; use Exp_Ch11;
-with Exp_Tss; use Exp_Tss;
with Hostparm; use Hostparm;
with Inline; use Inline;
with Itypes; use Itypes;
with Sem_Res; use Sem_Res;
with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
-with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
Spec := Make_Function_Specification (Loc,
Defining_Unit_Name =>
Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
- Subtype_Mark => New_Occurrence_Of (Standard_String, Loc));
+ Result_Definition => New_Occurrence_Of (Standard_String, Loc));
-- Calls to 'Image use the secondary stack, which must be cleaned
-- up after the task name is built.
then
null;
+ -- Nothing to be done if the type of the expression is limited, because
+ -- in this case the expression cannot be copied, and its use can only
+ -- be by reference and there is no need for the actual subtype.
+
+ elsif Is_Limited_Type (Exp_Typ) then
+ null;
+
else
Remove_Side_Effects (Exp);
Rewrite (Subtype_Indic,
and then Present (Abstract_Interfaces (Typ))
and then not (Is_Empty_Elmt_List (Abstract_Interfaces (Typ)))
then
- -- Skip the tag associated with the primary table.
+ -- Skip the tag associated with the primary table
pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
-- Handle task and protected types implementing interfaces
- if Ekind (Typ) = E_Protected_Type
- or else Ekind (Typ) = E_Task_Type
- then
+ if Is_Concurrent_Type (Typ) then
Typ := Corresponding_Record_Type (Typ);
end if;
+ if Is_Class_Wide_Type (Typ) then
+ Typ := Etype (Typ);
+ end if;
+
+ -- Handle entities from the limited view
+
+ if Ekind (Typ) = E_Incomplete_Type then
+ pragma Assert (Present (Non_Limited_View (Typ)));
+ Typ := Non_Limited_View (Typ);
+ end if;
+
Find_Tag (Typ);
pragma Assert (Found);
return AI_Tag;
return Count;
end Homonym_Number;
+ ----------------------------------
+ -- Implements_Limited_Interface --
+ ----------------------------------
+
+ function Implements_Limited_Interface (Typ : Entity_Id) return Boolean is
+ function Contains_Limited_Interface
+ (Ifaces : Elist_Id) return Boolean;
+ -- Given a list of interfaces, determine whether one of them is limited
+
+ --------------------------------
+ -- Contains_Limited_Interface --
+ --------------------------------
+
+ function Contains_Limited_Interface
+ (Ifaces : Elist_Id) return Boolean
+ is
+ Iface_Elmt : Elmt_Id;
+
+ begin
+ if not Present (Ifaces) then
+ return False;
+ end if;
+
+ Iface_Elmt := First_Elmt (Ifaces);
+
+ while Present (Iface_Elmt) loop
+ if Is_Limited_Record (Node (Iface_Elmt)) then
+ return True;
+ end if;
+
+ Iface_Elmt := Next_Elmt (Iface_Elmt);
+ end loop;
+
+ return False;
+ end Contains_Limited_Interface;
+
+ -- Start of processing for Implements_Limited_Interface
+
+ begin
+ -- Typ is a derived type and may implement a limited interface
+ -- through its parent subtype. Check the parent subtype as well
+ -- as any interfaces explicitly implemented at this level.
+
+ if Ekind (Typ) = E_Record_Type
+ and then Present (Parent_Subtype (Typ))
+ then
+ return Contains_Limited_Interface (Abstract_Interfaces (Typ))
+ or else Implements_Limited_Interface (Parent_Subtype (Typ));
+
+ -- Typ is an abstract type derived from some interface
+
+ elsif Is_Abstract (Typ) then
+ return Is_Interface (Etype (Typ))
+ and then Is_Limited_Record (Etype (Typ));
+
+ -- Typ may directly implement some interface
+
+ else
+ return Contains_Limited_Interface (Abstract_Interfaces (Typ));
+ end if;
+ end Implements_Limited_Interface;
+
------------------------------
-- In_Unconditional_Context --
------------------------------
or else Chars (E) = Name_uAssign
or else TSS_Name = TSS_Deep_Adjust
or else TSS_Name = TSS_Deep_Finalize
+ or else Chars (E) = Name_uDisp_Asynchronous_Select
+ or else Chars (E) = Name_uDisp_Conditional_Select
+ or else Chars (E) = Name_uDisp_Get_Prim_Op_Kind
+ or else Chars (E) = Name_uDisp_Timed_Select
then
return True;
end if;
procedure Kill_Dead_Code (N : Node_Id) is
begin
if Present (N) then
- Remove_Handler_Entries (N);
Remove_Warning_Messages (N);
-- Recurse into block statements and bodies to process declarations
-- chain, counting only entries in the curren scope. If an entity is not
-- overloaded, the returned number will be one.
+ function Implements_Limited_Interface (Typ : Entity_Id) return Boolean;
+ -- Ada 2005 (AI-345): Determine whether Typ implements some limited
+ -- interface. The interface may be of limited, protected, synchronized
+ -- or taks kind. Typ may also be derived from a type that implements a
+ -- limited interface.
+
function Inside_Init_Proc return Boolean;
-- Returns True if current scope is within an init proc
-- package see declarations in the runtime entity table below.
RTU_Null,
- -- Used as a null entry. Will cause an error if referenced.
+ -- Used as a null entry. Will cause an error if referenced
-- Children of Ada
System_Compare_Array_Unsigned_64,
System_Compare_Array_Unsigned_8,
System_Exception_Table,
- System_Exceptions,
System_Exn_Int,
System_Exn_LLF,
System_Exn_LLI,
RE_DT_Prologue_Size, -- Ada.Tags
RE_External_Tag, -- Ada.Tags
RE_Get_Access_Level, -- Ada.Tags
+ RE_Get_Entry_Index, -- Ada.Tags
RE_Get_External_Tag, -- Ada.Tags
RE_Get_Prim_Op_Address, -- Ada.Tags
+ RE_Get_Prim_Op_Kind, -- Ada.Tags
RE_Get_RC_Offset, -- Ada.Tags
RE_Get_Remotely_Callable, -- Ada.Tags
RE_Inherit_DT, -- Ada.Tags
RE_Inherit_TSD, -- Ada.Tags
RE_Internal_Tag, -- Ada.Tags
RE_Is_Descendant_At_Same_Level, -- Ada.Tags
+ RE_POK_Function, -- Ada.Tags
+ RE_POK_Procedure, -- Ada.Tags
+ RE_POK_Protected_Entry, -- Ada.Tags
+ RE_POK_Protected_Function, -- Ada.Tags
+ RE_POK_Protected_Procedure, -- Ada.Tags
+ RE_POK_Task_Entry, -- Ada.Tags
+ RE_POK_Task_Procedure, -- Ada.Tags
+ RE_Prim_Op_Kind, -- Ada.Tags
RE_Register_Interface_Tag, -- Ada.Tags
RE_Register_Tag, -- Ada.Tags
RE_Set_Access_Level, -- Ada.Tags
+ RE_Set_Entry_Index, -- Ada.Tags
RE_Set_Expanded_Name, -- Ada.Tags
RE_Set_External_Tag, -- Ada.Tags
RE_Set_Offset_To_Top, -- Ada.Tags
RE_Set_Prim_Op_Address, -- Ada.Tags
+ RE_Set_Prim_Op_Kind, -- Ada.Tags
RE_Set_RC_Offset, -- Ada.Tags
RE_Set_Remotely_Callable, -- Ada.Tags
RE_Set_TSD, -- Ada.Tags
RE_Register_Exception, -- System.Exception_Table
- RE_All_Others_Id, -- System.Exceptions
- RE_Handler_Record, -- System.Exceptions
- RE_Handler_Record_Ptr, -- System.Exceptions
- RE_Others_Id, -- System.Exceptions
- RE_Subprogram_Descriptor, -- System.Exceptions
- RE_Subprogram_Descriptor_0, -- System.Exceptions
- RE_Subprogram_Descriptor_1, -- System.Exceptions
- RE_Subprogram_Descriptor_2, -- System.Exceptions
- RE_Subprogram_Descriptor_3, -- System.Exceptions
- RE_Subprogram_Descriptor_List, -- System.Exceptions
- RE_Subprogram_Descriptor_Ptr, -- System.Exceptions
- RE_Subprogram_Descriptors_Record, -- System.Exceptions
- RE_Subprogram_Descriptors_Ptr, -- System.Exceptions
-
RE_Exn_Integer, -- System.Exn_Int
RE_Exn_Long_Long_Float, -- System.Exn_LLF
RE_Lt_F, -- System.Vax_Float_Operations
RE_Lt_G, -- System.Vax_Float_Operations
+ RE_Valid_D, -- System.Vax_Float_Operations
+ RE_Valid_F, -- System.Vax_Float_Operations
+ RE_Valid_G, -- System.Vax_Float_Operations
+
RE_Version_String, -- System.Version_Control
RE_Get_Version_String, -- System.Version_Control
RE_DT_Prologue_Size => Ada_Tags,
RE_External_Tag => Ada_Tags,
RE_Get_Access_Level => Ada_Tags,
+ RE_Get_Entry_Index => Ada_Tags,
RE_Get_External_Tag => Ada_Tags,
RE_Get_Prim_Op_Address => Ada_Tags,
+ RE_Get_Prim_Op_Kind => Ada_Tags,
RE_Get_RC_Offset => Ada_Tags,
RE_Get_Remotely_Callable => Ada_Tags,
RE_Inherit_DT => Ada_Tags,
RE_Inherit_TSD => Ada_Tags,
RE_Internal_Tag => Ada_Tags,
RE_Is_Descendant_At_Same_Level => Ada_Tags,
+ RE_POK_Function => Ada_Tags,
+ RE_POK_Procedure => Ada_Tags,
+ RE_POK_Protected_Entry => Ada_Tags,
+ RE_POK_Protected_Function => Ada_Tags,
+ RE_POK_Protected_Procedure => Ada_Tags,
+ RE_POK_Task_Entry => Ada_Tags,
+ RE_POK_Task_Procedure => Ada_Tags,
+ RE_Prim_Op_Kind => Ada_Tags,
RE_Register_Interface_Tag => Ada_Tags,
RE_Register_Tag => Ada_Tags,
RE_Set_Access_Level => Ada_Tags,
+ RE_Set_Entry_Index => Ada_Tags,
RE_Set_Expanded_Name => Ada_Tags,
RE_Set_External_Tag => Ada_Tags,
RE_Set_Offset_To_Top => Ada_Tags,
RE_Set_Prim_Op_Address => Ada_Tags,
+ RE_Set_Prim_Op_Kind => Ada_Tags,
RE_Set_RC_Offset => Ada_Tags,
RE_Set_Remotely_Callable => Ada_Tags,
RE_Set_TSD => Ada_Tags,
RE_Register_Exception => System_Exception_Table,
- RE_All_Others_Id => System_Exceptions,
- RE_Handler_Record => System_Exceptions,
- RE_Handler_Record_Ptr => System_Exceptions,
- RE_Others_Id => System_Exceptions,
- RE_Subprogram_Descriptor => System_Exceptions,
- RE_Subprogram_Descriptor_0 => System_Exceptions,
- RE_Subprogram_Descriptor_1 => System_Exceptions,
- RE_Subprogram_Descriptor_2 => System_Exceptions,
- RE_Subprogram_Descriptor_3 => System_Exceptions,
- RE_Subprogram_Descriptor_List => System_Exceptions,
- RE_Subprogram_Descriptor_Ptr => System_Exceptions,
- RE_Subprogram_Descriptors_Record => System_Exceptions,
- RE_Subprogram_Descriptors_Ptr => System_Exceptions,
-
RE_Exn_Integer => System_Exn_Int,
RE_Exn_Long_Long_Float => System_Exn_LLF,
RE_Lt_F => System_Vax_Float_Operations,
RE_Lt_G => System_Vax_Float_Operations,
+ RE_Valid_D => System_Vax_Float_Operations,
+ RE_Valid_F => System_Vax_Float_Operations,
+ RE_Valid_G => System_Vax_Float_Operations,
+
RE_Version_String => System_Version_Control,
RE_Get_Version_String => System_Version_Control,
-- not mean that an attempt to load it subsequently would fail.
procedure Set_RTU_Loaded (N : Node_Id);
- -- Register the predefined unit N as already loaded.
+ -- Register the predefined unit N as already loaded
procedure Text_IO_Kludge (Nam : Node_Id);
-- In Ada 83, and hence for compatibility in Ada 9X, package Text_IO has
and then Nkind (Trigger) /= N_Delay_Relative_Statement
and then Nkind (Trigger) /= N_Entry_Call_Statement
then
- Error_Msg_N
- ("triggering statement must be delay or entry call", Trigger);
+ if Ada_Version < Ada_05 then
+ Error_Msg_N
+ ("triggering statement must be delay or entry call", Trigger);
+
+ -- Ada 2005 (AI-345): If a procedure_call_statement is used
+ -- for a procedure_or_entry_call, the procedure_name or pro-
+ -- cedure_prefix of the procedure_call_statement shall denote
+ -- an entry renamed by a procedure, or (a view of) a primitive
+ -- subprogram of a limited interface whose first parameter is
+ -- a controlling parameter.
+
+ elsif Nkind (Trigger) = N_Procedure_Call_Statement
+ and then not Is_Renamed_Entry (Entity (Name (Trigger)))
+ and then not Is_Controlling_Limited_Procedure
+ (Entity (Name (Trigger)))
+ then
+ Error_Msg_N ("triggering statement must be delay, procedure " &
+ "or entry call", Trigger);
+ end if;
end if;
if Is_Non_Empty_List (Statements (N)) then
and then Matches_Prefixed_View_Profile (Ifaces,
Parameter_Specifications (Spec),
Parameter_Specifications (Parent (Hom)))
- and then Etype (Subtype_Mark (Spec)) =
- Etype (Subtype_Mark (Parent (Hom)))
+ and then Etype (Result_Definition (Spec)) =
+ Etype (Result_Definition (Parent (Hom)))
then
Overrides := True;
exit;
Uint_8 : constant Uint;
Uint_9 : constant Uint;
Uint_10 : constant Uint;
+ Uint_11 : constant Uint;
Uint_12 : constant Uint;
+ Uint_13 : constant Uint;
+ Uint_14 : constant Uint;
Uint_15 : constant Uint;
Uint_16 : constant Uint;
Uint_24 : constant Uint;
Uint_8 : constant Uint := Uint (Uint_Direct_Bias + 8);
Uint_9 : constant Uint := Uint (Uint_Direct_Bias + 9);
Uint_10 : constant Uint := Uint (Uint_Direct_Bias + 10);
+ Uint_11 : constant Uint := Uint (Uint_Direct_Bias + 11);
Uint_12 : constant Uint := Uint (Uint_Direct_Bias + 12);
+ Uint_13 : constant Uint := Uint (Uint_Direct_Bias + 13);
+ Uint_14 : constant Uint := Uint (Uint_Direct_Bias + 14);
Uint_15 : constant Uint := Uint (Uint_Direct_Bias + 15);
Uint_16 : constant Uint := Uint (Uint_Direct_Bias + 16);
Uint_24 : constant Uint := Uint (Uint_Direct_Bias + 24);
OSDN Git Service
