blob: 6ade54be177bd7868db3641bf3075f072ef193af [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- E X P _ D I S P --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Atree; use Atree;
with Checks; use Checks;
with Debug; use Debug;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Elists; use Elists;
with Errout; use Errout;
with Expander; use Expander;
with Exp_Atag; use Exp_Atag;
with Exp_Ch6; use Exp_Ch6;
with Exp_CG; use Exp_CG;
with Exp_Dbug; use Exp_Dbug;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
with Ghost; use Ghost;
with Itypes; use Itypes;
with Layout; use Layout;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Namet; use Namet;
with Opt; use Opt;
with Output; use Output;
with Restrict; use Restrict;
with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch7; use Sem_Ch7;
with Sem_Ch8; use Sem_Ch8;
with Sem_Disp; use Sem_Disp;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
with SCIL_LL; use SCIL_LL;
with Tbuild; use Tbuild;
package body Exp_Disp is
-----------------------
-- Local Subprograms --
-----------------------
function Default_Prim_Op_Position (E : Entity_Id) return Uint;
-- Ada 2005 (AI-251): Returns the fixed position in the dispatch table
-- of the default primitive operations.
function Has_DT (Typ : Entity_Id) return Boolean;
pragma Inline (Has_DT);
-- Returns true if we generate a dispatch table for tagged type Typ
function Is_Predefined_Dispatching_Alias (Prim : Entity_Id) return Boolean;
-- Returns true if Prim is not a predefined dispatching primitive but it is
-- an alias of a predefined dispatching primitive (i.e. through a renaming)
function New_Value (From : Node_Id) return Node_Id;
-- From is the original Expression. New_Value is equivalent to a call to
-- Duplicate_Subexpr with an explicit dereference when From is an access
-- parameter.
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 RE_Prim_Op_Kind
-- enumeration value.
function Tagged_Kind (T : Entity_Id) return Node_Id;
-- Ada 2005 (AI-345): Determine the tagged kind of T and return a reference
-- to an RE_Tagged_Kind enumeration value.
----------------------
-- Apply_Tag_Checks --
----------------------
procedure Apply_Tag_Checks (Call_Node : Node_Id) is
Loc : constant Source_Ptr := Sloc (Call_Node);
Ctrl_Arg : constant Node_Id := Controlling_Argument (Call_Node);
Ctrl_Typ : constant Entity_Id := Base_Type (Etype (Ctrl_Arg));
Param_List : constant List_Id := Parameter_Associations (Call_Node);
Subp : Entity_Id;
CW_Typ : Entity_Id;
Param : Node_Id;
Typ : Entity_Id;
Eq_Prim_Op : Entity_Id := Empty;
begin
if No_Run_Time_Mode then
Error_Msg_CRT ("tagged types", Call_Node);
return;
end if;
-- Apply_Tag_Checks is called directly from the semantics, so we
-- need a check to see whether expansion is active before proceeding.
-- In addition, there is no need to expand the call when compiling
-- under restriction No_Dispatching_Calls; the semantic analyzer has
-- previously notified the violation of this restriction.
if not Expander_Active
or else Restriction_Active (No_Dispatching_Calls)
then
return;
end if;
-- Set subprogram. If this is an inherited operation that was
-- overridden, the body that is being called is its alias.
Subp := Entity (Name (Call_Node));
if Present (Alias (Subp))
and then Is_Inherited_Operation (Subp)
and then No (DTC_Entity (Subp))
then
Subp := Alias (Subp);
end if;
-- Definition of the class-wide type and the tagged type
-- If the controlling argument is itself a tag rather than a tagged
-- object, then use the class-wide type associated with the subprogram's
-- controlling type. This case can occur when a call to an inherited
-- primitive has an actual that originated from a default parameter
-- given by a tag-indeterminate call and when there is no other
-- controlling argument providing the tag (AI-239 requires dispatching).
-- This capability of dispatching directly by tag is also needed by the
-- implementation of AI-260 (for the generic dispatching constructors).
if Is_RTE (Ctrl_Typ, RE_Tag)
or else Is_RTE (Ctrl_Typ, RE_Interface_Tag)
then
CW_Typ := Class_Wide_Type (Find_Dispatching_Type (Subp));
-- Class_Wide_Type is applied to the expressions used to initialize
-- CW_Typ, to ensure that CW_Typ always denotes a class-wide type, since
-- there are cases where the controlling type is resolved to a specific
-- type (such as for designated types of arguments such as CW'Access).
elsif Is_Access_Type (Ctrl_Typ) then
CW_Typ := Class_Wide_Type (Designated_Type (Ctrl_Typ));
else
CW_Typ := Class_Wide_Type (Ctrl_Typ);
end if;
Typ := Find_Specific_Type (CW_Typ);
if not Is_Limited_Type (Typ) then
Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
end if;
-- Dispatching call to C++ primitive
if Is_CPP_Class (Typ) then
null;
-- Dispatching call to Ada primitive
elsif Present (Param_List) then
-- Generate the Tag checks when appropriate
Param := First_Actual (Call_Node);
while Present (Param) loop
-- No tag check with itself
if Param = Ctrl_Arg then
null;
-- No tag check for parameter whose type is neither tagged nor
-- access to tagged (for access parameters)
elsif No (Find_Controlling_Arg (Param)) then
null;
-- No tag check for function dispatching on result if the
-- Tag given by the context is this one
elsif Find_Controlling_Arg (Param) = Ctrl_Arg then
null;
-- "=" is the only dispatching operation allowed to get operands
-- with incompatible tags (it just returns false). We use
-- Duplicate_Subexpr_Move_Checks instead of calling Relocate_Node
-- because the value will be duplicated to check the tags.
elsif Subp = Eq_Prim_Op then
null;
-- No check in presence of suppress flags
elsif Tag_Checks_Suppressed (Etype (Param))
or else (Is_Access_Type (Etype (Param))
and then Tag_Checks_Suppressed
(Designated_Type (Etype (Param))))
then
null;
-- Optimization: no tag checks if the parameters are identical
elsif Is_Entity_Name (Param)
and then Is_Entity_Name (Ctrl_Arg)
and then Entity (Param) = Entity (Ctrl_Arg)
then
null;
-- Now we need to generate the Tag check
else
-- Generate code for tag equality check
-- Perhaps should have Checks.Apply_Tag_Equality_Check???
Insert_Action (Ctrl_Arg,
Make_Implicit_If_Statement (Call_Node,
Condition =>
Make_Op_Ne (Loc,
Left_Opnd =>
Make_Selected_Component (Loc,
Prefix => New_Value (Ctrl_Arg),
Selector_Name =>
New_Occurrence_Of
(First_Tag_Component (Typ), Loc)),
Right_Opnd =>
Make_Selected_Component (Loc,
Prefix =>
Unchecked_Convert_To (Typ, New_Value (Param)),
Selector_Name =>
New_Occurrence_Of
(First_Tag_Component (Typ), Loc))),
Then_Statements =>
New_List (New_Constraint_Error (Loc))));
end if;
Next_Actual (Param);
end loop;
end if;
end Apply_Tag_Checks;
------------------------
-- Building_Static_DT --
------------------------
function Building_Static_DT (Typ : Entity_Id) return Boolean is
Root_Typ : Entity_Id := Root_Type (Typ);
Static_DT : Boolean;
begin
-- Handle private types
if Present (Full_View (Root_Typ)) then
Root_Typ := Full_View (Root_Typ);
end if;
Static_DT :=
Building_Static_Dispatch_Tables
and then Is_Library_Level_Tagged_Type (Typ)
-- If the type is derived from a CPP class we cannot statically
-- build the dispatch tables because we must inherit primitives
-- from the CPP side.
and then not Is_CPP_Class (Root_Typ);
if not Static_DT then
Check_Restriction (Static_Dispatch_Tables, Typ);
end if;
return Static_DT;
end Building_Static_DT;
----------------------------------
-- Building_Static_Secondary_DT --
----------------------------------
function Building_Static_Secondary_DT (Typ : Entity_Id) return Boolean is
Full_Typ : Entity_Id := Typ;
Root_Typ : Entity_Id := Root_Type (Typ);
Static_DT : Boolean;
begin
-- Handle private types
if Present (Full_View (Typ)) then
Full_Typ := Full_View (Typ);
end if;
if Present (Full_View (Root_Typ)) then
Root_Typ := Full_View (Root_Typ);
end if;
Static_DT :=
Building_Static_DT (Full_Typ)
and then not Is_Interface (Full_Typ)
and then Has_Interfaces (Full_Typ)
and then (Full_Typ = Root_Typ
or else not Is_Variable_Size_Record (Etype (Full_Typ)));
if not Static_DT
and then not Is_Interface (Full_Typ)
and then Has_Interfaces (Full_Typ)
then
Check_Restriction (Static_Dispatch_Tables, Typ);
end if;
return Static_DT;
end Building_Static_Secondary_DT;
----------------------------------
-- Build_Static_Dispatch_Tables --
----------------------------------
procedure Build_Static_Dispatch_Tables (N : Node_Id) is
Target_List : List_Id;
procedure Build_Dispatch_Tables (List : List_Id);
-- Build the static dispatch table of tagged types found in the list of
-- declarations. The generated nodes are added at the end of Target_List
procedure Build_Package_Dispatch_Tables (N : Node_Id);
-- Build static dispatch tables associated with package declaration N
---------------------------
-- Build_Dispatch_Tables --
---------------------------
procedure Build_Dispatch_Tables (List : List_Id) is
D : Node_Id;
begin
D := First (List);
while Present (D) loop
-- Handle nested packages and package bodies recursively. The
-- generated code is placed on the Target_List established for
-- the enclosing compilation unit.
if Nkind (D) = N_Package_Declaration then
Build_Package_Dispatch_Tables (D);
elsif Nkind (D) = N_Package_Body then
Build_Dispatch_Tables (Declarations (D));
elsif Nkind (D) = N_Package_Body_Stub
and then Present (Library_Unit (D))
then
Build_Dispatch_Tables
(Declarations (Proper_Body (Unit (Library_Unit (D)))));
-- Handle full type declarations and derivations of library level
-- tagged types
elsif Nkind (D) in
N_Full_Type_Declaration | N_Derived_Type_Definition
and then Is_Library_Level_Tagged_Type (Defining_Entity (D))
and then Ekind (Defining_Entity (D)) /= E_Record_Subtype
and then not Is_Private_Type (Defining_Entity (D))
then
-- We do not generate dispatch tables for the internal types
-- created for a type extension with unknown discriminants
-- The needed information is shared with the source type,
-- See Expand_N_Record_Extension.
if Is_Underlying_Record_View (Defining_Entity (D))
or else
(not Comes_From_Source (Defining_Entity (D))
and then
Has_Unknown_Discriminants (Etype (Defining_Entity (D)))
and then
not Comes_From_Source
(First_Subtype (Defining_Entity (D))))
then
null;
else
Insert_List_After_And_Analyze (Last (Target_List),
Make_DT (Defining_Entity (D)));
end if;
-- Handle private types of library level tagged types. We must
-- exchange the private and full-view to ensure the correct
-- expansion. If the full view is a synchronized type ignore
-- the type because the table will be built for the corresponding
-- record type, that has its own declaration.
elsif (Nkind (D) = N_Private_Type_Declaration
or else Nkind (D) = N_Private_Extension_Declaration)
and then Present (Full_View (Defining_Entity (D)))
then
declare
E1 : constant Entity_Id := Defining_Entity (D);
E2 : constant Entity_Id := Full_View (E1);
begin
if Is_Library_Level_Tagged_Type (E2)
and then Ekind (E2) /= E_Record_Subtype
and then not Is_Concurrent_Type (E2)
then
Exchange_Declarations (E1);
Insert_List_After_And_Analyze (Last (Target_List),
Make_DT (E1));
Exchange_Declarations (E2);
end if;
end;
end if;
Next (D);
end loop;
end Build_Dispatch_Tables;
-----------------------------------
-- Build_Package_Dispatch_Tables --
-----------------------------------
procedure Build_Package_Dispatch_Tables (N : Node_Id) is
Spec : constant Node_Id := Specification (N);
Id : constant Entity_Id := Defining_Entity (N);
Vis_Decls : constant List_Id := Visible_Declarations (Spec);
Priv_Decls : constant List_Id := Private_Declarations (Spec);
begin
Push_Scope (Id);
if Present (Priv_Decls) then
Build_Dispatch_Tables (Vis_Decls);
Build_Dispatch_Tables (Priv_Decls);
elsif Present (Vis_Decls) then
Build_Dispatch_Tables (Vis_Decls);
end if;
Pop_Scope;
end Build_Package_Dispatch_Tables;
-- Start of processing for Build_Static_Dispatch_Tables
begin
if not Expander_Active
or else not Tagged_Type_Expansion
then
return;
end if;
if Nkind (N) = N_Package_Declaration then
declare
Spec : constant Node_Id := Specification (N);
Vis_Decls : constant List_Id := Visible_Declarations (Spec);
Priv_Decls : constant List_Id := Private_Declarations (Spec);
begin
if Present (Priv_Decls)
and then Is_Non_Empty_List (Priv_Decls)
then
Target_List := Priv_Decls;
elsif not Present (Vis_Decls) then
Target_List := New_List;
Set_Private_Declarations (Spec, Target_List);
else
Target_List := Vis_Decls;
end if;
Build_Package_Dispatch_Tables (N);
end;
else pragma Assert (Nkind (N) = N_Package_Body);
Target_List := Declarations (N);
Build_Dispatch_Tables (Target_List);
end if;
end Build_Static_Dispatch_Tables;
------------------------------
-- Convert_Tag_To_Interface --
------------------------------
function Convert_Tag_To_Interface
(Typ : Entity_Id;
Expr : Node_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Expr);
Anon_Type : Entity_Id;
Result : Node_Id;
begin
pragma Assert (Is_Class_Wide_Type (Typ)
and then Is_Interface (Typ)
and then
((Nkind (Expr) = N_Selected_Component
and then Is_Tag (Entity (Selector_Name (Expr))))
or else
(Nkind (Expr) = N_Function_Call
and then Is_RTE (Entity (Name (Expr)), RE_Displace))));
Anon_Type := Create_Itype (E_Anonymous_Access_Type, Expr);
Set_Directly_Designated_Type (Anon_Type, Typ);
Set_Etype (Anon_Type, Anon_Type);
Set_Can_Never_Be_Null (Anon_Type);
-- Decorate the size and alignment attributes of the anonymous access
-- type, as required by the back end.
Layout_Type (Anon_Type);
if Nkind (Expr) = N_Selected_Component
and then Is_Tag (Entity (Selector_Name (Expr)))
then
Result :=
Make_Explicit_Dereference (Loc,
Unchecked_Convert_To (Anon_Type,
Make_Attribute_Reference (Loc,
Prefix => Expr,
Attribute_Name => Name_Address)));
else
Result :=
Make_Explicit_Dereference (Loc,
Unchecked_Convert_To (Anon_Type, Expr));
end if;
return Result;
end Convert_Tag_To_Interface;
-------------------
-- CPP_Num_Prims --
-------------------
function CPP_Num_Prims (Typ : Entity_Id) return Nat is
CPP_Typ : Entity_Id;
Tag_Comp : Entity_Id;
begin
if not Is_Tagged_Type (Typ)
or else not Is_CPP_Class (Root_Type (Typ))
then
return 0;
else
CPP_Typ := Enclosing_CPP_Parent (Typ);
Tag_Comp := First_Tag_Component (CPP_Typ);
-- If number of primitives already set in the tag component, use it
if Present (Tag_Comp)
and then Present (DT_Entry_Count (Tag_Comp))
then
return UI_To_Int (DT_Entry_Count (Tag_Comp));
-- Otherwise, count the primitives of the enclosing CPP type
else
return List_Length (Primitive_Operations (CPP_Typ));
end if;
end if;
end CPP_Num_Prims;
------------------------------
-- Default_Prim_Op_Position --
------------------------------
function Default_Prim_Op_Position (E : Entity_Id) return Uint is
TSS_Name : TSS_Name_Type;
begin
Get_Name_String (Chars (E));
TSS_Name :=
TSS_Name_Type
(Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len));
if Chars (E) = Name_uSize then
return Uint_1;
elsif TSS_Name = TSS_Stream_Read then
return Uint_2;
elsif TSS_Name = TSS_Stream_Write then
return Uint_3;
elsif TSS_Name = TSS_Stream_Input then
return Uint_4;
elsif TSS_Name = TSS_Stream_Output then
return Uint_5;
elsif Chars (E) = Name_Op_Eq then
return Uint_6;
elsif Chars (E) = Name_uAssign then
return Uint_7;
elsif TSS_Name = TSS_Deep_Adjust then
return Uint_8;
elsif TSS_Name = TSS_Deep_Finalize then
return Uint_9;
elsif TSS_Name = TSS_Put_Image then
return Uint_10;
-- In VM targets unconditionally allow obtaining the position associated
-- with predefined interface primitives since in these platforms any
-- tagged type has these primitives.
elsif Ada_Version >= Ada_2005 or else not Tagged_Type_Expansion then
if 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_Get_Task_Id then
return Uint_14;
elsif Chars (E) = Name_uDisp_Requeue then
return Uint_15;
elsif Chars (E) = Name_uDisp_Timed_Select then
return Uint_16;
end if;
end if;
raise Program_Error;
end Default_Prim_Op_Position;
----------------------
-- Elab_Flag_Needed --
----------------------
function Elab_Flag_Needed (Typ : Entity_Id) return Boolean is
begin
return Ada_Version >= Ada_2005
and then not Is_Interface (Typ)
and then Has_Interfaces (Typ)
and then not Building_Static_DT (Typ);
end Elab_Flag_Needed;
-----------------------------
-- Expand_Dispatching_Call --
-----------------------------
procedure Expand_Dispatching_Call (Call_Node : Node_Id) is
Loc : constant Source_Ptr := Sloc (Call_Node);
Call_Typ : constant Entity_Id := Etype (Call_Node);
Ctrl_Arg : constant Node_Id := Controlling_Argument (Call_Node);
Ctrl_Typ : constant Entity_Id := Base_Type (Etype (Ctrl_Arg));
Param_List : constant List_Id := Parameter_Associations (Call_Node);
Subp : Entity_Id;
CW_Typ : Entity_Id;
New_Call : Node_Id;
New_Call_Name : Node_Id;
New_Params : List_Id := No_List;
Param : Node_Id;
Res_Typ : Entity_Id;
Subp_Ptr_Typ : Entity_Id;
Subp_Typ : Entity_Id;
Typ : Entity_Id;
Eq_Prim_Op : Entity_Id := Empty;
Controlling_Tag : Node_Id;
function New_Value (From : Node_Id) return Node_Id;
-- From is the original Expression. New_Value is equivalent to a call
-- to Duplicate_Subexpr with an explicit dereference when From is an
-- access parameter.
---------------
-- New_Value --
---------------
function New_Value (From : Node_Id) return Node_Id is
Res : constant Node_Id := Duplicate_Subexpr (From);
begin
if Is_Access_Type (Etype (From)) then
return
Make_Explicit_Dereference (Sloc (From),
Prefix => Res);
else
return Res;
end if;
end New_Value;
-- Local variables
New_Node : Node_Id;
SCIL_Node : Node_Id := Empty;
SCIL_Related_Node : Node_Id := Call_Node;
-- Start of processing for Expand_Dispatching_Call
begin
if No_Run_Time_Mode then
Error_Msg_CRT ("tagged types", Call_Node);
return;
end if;
-- Expand_Dispatching_Call is called directly from the semantics, so we
-- only proceed if the expander is active.
if not Expander_Active
-- And there is no need to expand the call if we are compiling under
-- restriction No_Dispatching_Calls; the semantic analyzer has
-- previously notified the violation of this restriction.
or else Restriction_Active (No_Dispatching_Calls)
-- No action needed if the dispatching call has been already expanded
or else Is_Expanded_Dispatching_Call (Name (Call_Node))
then
return;
end if;
-- Set subprogram. If this is an inherited operation that was
-- overridden, the body that is being called is its alias.
Subp := Entity (Name (Call_Node));
if Present (Alias (Subp))
and then Is_Inherited_Operation (Subp)
and then No (DTC_Entity (Subp))
then
Subp := Alias (Subp);
end if;
-- Definition of the class-wide type and the tagged type
-- If the controlling argument is itself a tag rather than a tagged
-- object, then use the class-wide type associated with the subprogram's
-- controlling type. This case can occur when a call to an inherited
-- primitive has an actual that originated from a default parameter
-- given by a tag-indeterminate call and when there is no other
-- controlling argument providing the tag (AI-239 requires dispatching).
-- This capability of dispatching directly by tag is also needed by the
-- implementation of AI-260 (for the generic dispatching constructors).
if Is_RTE (Ctrl_Typ, RE_Tag)
or else Is_RTE (Ctrl_Typ, RE_Interface_Tag)
then
CW_Typ := Class_Wide_Type (Find_Dispatching_Type (Subp));
-- Class_Wide_Type is applied to the expressions used to initialize
-- CW_Typ, to ensure that CW_Typ always denotes a class-wide type, since
-- there are cases where the controlling type is resolved to a specific
-- type (such as for designated types of arguments such as CW'Access).
elsif Is_Access_Type (Ctrl_Typ) then
CW_Typ := Class_Wide_Type (Designated_Type (Ctrl_Typ));
else
CW_Typ := Class_Wide_Type (Ctrl_Typ);
end if;
Typ := Find_Specific_Type (CW_Typ);
-- The tagged type of a dispatching call must be frozen at this stage
pragma Assert (Is_Frozen (Typ));
if not Is_Limited_Type (Typ) then
Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
end if;
-- Dispatching call to C++ primitive. Create a new parameter list
-- with no tag checks.
New_Params := New_List;
if Is_CPP_Class (Typ) then
Param := First_Actual (Call_Node);
while Present (Param) loop
Append_To (New_Params, Relocate_Node (Param));
Next_Actual (Param);
end loop;
-- Dispatching call to Ada primitive
elsif Present (Param_List) then
Apply_Tag_Checks (Call_Node);
Param := First_Actual (Call_Node);
while Present (Param) loop
-- Cases in which we may have generated run-time checks. Note that
-- we strip any qualification from Param before comparing with the
-- already-stripped controlling argument.
if Unqualify (Param) = Ctrl_Arg or else Subp = Eq_Prim_Op then
Append_To (New_Params,
Duplicate_Subexpr_Move_Checks (Param));
elsif Nkind (Parent (Param)) /= N_Parameter_Association
or else not Is_Accessibility_Actual (Parent (Param))
then
Append_To (New_Params, Relocate_Node (Param));
end if;
Next_Actual (Param);
end loop;
end if;
-- Generate the appropriate subprogram pointer type
if Etype (Subp) = Typ then
Res_Typ := CW_Typ;
else
Res_Typ := Etype (Subp);
end if;
Subp_Typ := Create_Itype (E_Subprogram_Type, Call_Node);
Subp_Ptr_Typ := Create_Itype (E_Access_Subprogram_Type, Call_Node);
Set_Etype (Subp_Typ, Res_Typ);
Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp));
Set_Convention (Subp_Typ, Convention (Subp));
-- Notify gigi that the designated type is a dispatching primitive
Set_Is_Dispatch_Table_Entity (Subp_Typ);
-- Create a new list of parameters which is a copy of the old formal
-- list including the creation of a new set of matching entities.
declare
Old_Formal : Entity_Id := First_Formal (Subp);
New_Formal : Entity_Id;
Last_Formal : Entity_Id := Empty;
begin
if Present (Old_Formal) then
New_Formal := New_Copy (Old_Formal);
Set_First_Entity (Subp_Typ, New_Formal);
Param := First_Actual (Call_Node);
loop
Set_Scope (New_Formal, Subp_Typ);
-- Change all the controlling argument types to be class-wide
-- to avoid a recursion in dispatching.
if Is_Controlling_Formal (New_Formal) then
Set_Etype (New_Formal, Etype (Param));
end if;
-- If the type of the formal is an itype, there was code here
-- introduced in 1998 in revision 1.46, to create a new itype
-- by copy. This seems useless, and in fact leads to semantic
-- errors when the itype is the completion of a type derived
-- from a private type.
Last_Formal := New_Formal;
Next_Formal (Old_Formal);
exit when No (Old_Formal);
Link_Entities (New_Formal, New_Copy (Old_Formal));
Next_Entity (New_Formal);
Next_Actual (Param);
end loop;
Unlink_Next_Entity (New_Formal);
Set_Last_Entity (Subp_Typ, Last_Formal);
end if;
-- Now that the explicit formals have been duplicated, any extra
-- formals needed by the subprogram must be duplicated; we know
-- that extra formals are available because they were added when
-- the tagged type was frozen (see Expand_Freeze_Record_Type).
pragma Assert (Is_Frozen (Typ));
-- Warning: The addition of the extra formals cannot be performed
-- here invoking Create_Extra_Formals since we must ensure that all
-- the extra formals of the pointer type and the target subprogram
-- match (and for functions that return a tagged type the profile of
-- the built subprogram type always returns a class-wide type, which
-- may affect the addition of some extra formals).
if Present (Last_Formal)
and then Present (Extra_Formal (Last_Formal))
then
Old_Formal := Extra_Formal (Last_Formal);
New_Formal := New_Copy (Old_Formal);
Set_Scope (New_Formal, Subp_Typ);
Set_Extra_Formal (Last_Formal, New_Formal);
Set_Extra_Formals (Subp_Typ, New_Formal);
if Ekind (Subp) = E_Function
and then Present (Extra_Accessibility_Of_Result (Subp))
and then Extra_Accessibility_Of_Result (Subp) = Old_Formal
then
Set_Extra_Accessibility_Of_Result (Subp_Typ, New_Formal);
end if;
Old_Formal := Extra_Formal (Old_Formal);
while Present (Old_Formal) loop
Set_Extra_Formal (New_Formal, New_Copy (Old_Formal));
New_Formal := Extra_Formal (New_Formal);
Set_Scope (New_Formal, Subp_Typ);
if Ekind (Subp) = E_Function
and then Present (Extra_Accessibility_Of_Result (Subp))
and then Extra_Accessibility_Of_Result (Subp) = Old_Formal
then
Set_Extra_Accessibility_Of_Result (Subp_Typ, New_Formal);
end if;
Old_Formal := Extra_Formal (Old_Formal);
end loop;
end if;
end;
-- Complete description of pointer type, including size information, as
-- must be done with itypes to prevent order-of-elaboration anomalies
-- in gigi.
Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ);
Set_Directly_Designated_Type (Subp_Ptr_Typ, Subp_Typ);
Set_Convention (Subp_Ptr_Typ, Convention (Subp_Typ));
Layout_Type (Subp_Ptr_Typ);
-- If the controlling argument is a value of type Ada.Tag or an abstract
-- interface class-wide type then use it directly. Otherwise, the tag
-- must be extracted from the controlling object.
if Is_RTE (Ctrl_Typ, RE_Tag)
or else Is_RTE (Ctrl_Typ, RE_Interface_Tag)
then
Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg);
-- Extract the tag from an unchecked type conversion. Done to avoid
-- the expansion of additional code just to obtain the value of such
-- tag because the current management of interface type conversions
-- generates in some cases this unchecked type conversion with the
-- tag of the object (see Expand_Interface_Conversion).
elsif Nkind (Ctrl_Arg) = N_Unchecked_Type_Conversion
and then
(Is_RTE (Etype (Expression (Ctrl_Arg)), RE_Tag)
or else
Is_RTE (Etype (Expression (Ctrl_Arg)), RE_Interface_Tag))
then
Controlling_Tag := Duplicate_Subexpr (Expression (Ctrl_Arg));
-- Ada 2005 (AI-251): Abstract interface class-wide type
elsif Is_Interface (Ctrl_Typ)
and then Is_Class_Wide_Type (Ctrl_Typ)
then
Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg);
elsif Is_Access_Type (Ctrl_Typ) then
Controlling_Tag :=
Make_Selected_Component (Loc,
Prefix =>
Make_Explicit_Dereference (Loc,
Duplicate_Subexpr_Move_Checks (Ctrl_Arg)),
Selector_Name => New_Occurrence_Of (DTC_Entity (Subp), Loc));
else
Controlling_Tag :=
Make_Selected_Component (Loc,
Prefix => Duplicate_Subexpr_Move_Checks (Ctrl_Arg),
Selector_Name => New_Occurrence_Of (DTC_Entity (Subp), Loc));
end if;
-- Handle dispatching calls to predefined primitives
if Is_Predefined_Dispatching_Operation (Subp)
or else Is_Predefined_Dispatching_Alias (Subp)
then
Build_Get_Predefined_Prim_Op_Address (Loc,
Tag_Node => Controlling_Tag,
Position => DT_Position (Subp),
New_Node => New_Node);
-- Handle dispatching calls to user-defined primitives
else
Build_Get_Prim_Op_Address (Loc,
Typ => Underlying_Type (Find_Dispatching_Type (Subp)),
Tag_Node => Controlling_Tag,
Position => DT_Position (Subp),
New_Node => New_Node);
end if;
New_Call_Name :=
Unchecked_Convert_To (Subp_Ptr_Typ, New_Node);
-- Generate the SCIL node for this dispatching call. Done now because
-- attribute SCIL_Controlling_Tag must be set after the new call name
-- is built to reference the nodes that will see the SCIL backend
-- (because Build_Get_Prim_Op_Address generates an unchecked type
-- conversion which relocates the controlling tag node).
if Generate_SCIL then
SCIL_Node := Make_SCIL_Dispatching_Call (Sloc (Call_Node));
Set_SCIL_Entity (SCIL_Node, Typ);
Set_SCIL_Target_Prim (SCIL_Node, Subp);
-- Common case: the controlling tag is the tag of an object
-- (for example, obj.tag)
if Nkind (Controlling_Tag) = N_Selected_Component then
Set_SCIL_Controlling_Tag (SCIL_Node, Controlling_Tag);
-- Handle renaming of selected component
elsif Nkind (Controlling_Tag) = N_Identifier
and then Nkind (Parent (Entity (Controlling_Tag))) =
N_Object_Renaming_Declaration
and then Nkind (Name (Parent (Entity (Controlling_Tag)))) =
N_Selected_Component
then
Set_SCIL_Controlling_Tag (SCIL_Node,
Name (Parent (Entity (Controlling_Tag))));
-- If the controlling tag is an identifier, the SCIL node references
-- the corresponding object or parameter declaration
elsif Nkind (Controlling_Tag) = N_Identifier
and then Nkind (Parent (Entity (Controlling_Tag))) in
N_Object_Declaration | N_Parameter_Specification
then
Set_SCIL_Controlling_Tag (SCIL_Node,
Parent (Entity (Controlling_Tag)));
-- If the controlling tag is a dereference, the SCIL node references
-- the corresponding object or parameter declaration
elsif Nkind (Controlling_Tag) = N_Explicit_Dereference
and then Nkind (Prefix (Controlling_Tag)) = N_Identifier
and then Nkind (Parent (Entity (Prefix (Controlling_Tag)))) in
N_Object_Declaration | N_Parameter_Specification
then
Set_SCIL_Controlling_Tag (SCIL_Node,
Parent (Entity (Prefix (Controlling_Tag))));
-- For a direct reference of the tag of the type the SCIL node
-- references the internal object declaration containing the tag
-- of the type.
elsif Nkind (Controlling_Tag) = N_Attribute_Reference
and then Attribute_Name (Controlling_Tag) = Name_Tag
then
Set_SCIL_Controlling_Tag (SCIL_Node,
Parent
(Node
(First_Elmt
(Access_Disp_Table (Entity (Prefix (Controlling_Tag)))))));
-- Interfaces are not supported. For now we leave the SCIL node
-- decorated with the Controlling_Tag. More work needed here???
elsif Is_Interface (Etype (Controlling_Tag)) then
Set_SCIL_Controlling_Tag (SCIL_Node, Controlling_Tag);
else
pragma Assert (False);
null;
end if;
end if;
if Nkind (Call_Node) = N_Function_Call then
New_Call :=
Make_Function_Call (Loc,
Name => New_Call_Name,
Parameter_Associations => New_Params);
-- If this is a dispatching "=", we must first compare the tags so
-- we generate: x.tag = y.tag and then x = y
if Subp = Eq_Prim_Op then
Param := First_Actual (Call_Node);
New_Call :=
Make_And_Then (Loc,
Left_Opnd =>
Make_Op_Eq (Loc,
Left_Opnd =>
Make_Selected_Component (Loc,
Prefix => New_Value (Param),
Selector_Name =>
New_Occurrence_Of (First_Tag_Component (Typ),
Loc)),
Right_Opnd =>
Make_Selected_Component (Loc,
Prefix =>
Unchecked_Convert_To (Typ,
New_Value (Next_Actual (Param))),
Selector_Name =>
New_Occurrence_Of
(First_Tag_Component (Typ), Loc))),
Right_Opnd => New_Call);
SCIL_Related_Node := Right_Opnd (New_Call);
end if;
else
New_Call :=
Make_Procedure_Call_Statement (Loc,
Name => New_Call_Name,
Parameter_Associations => New_Params);
end if;
-- Register the dispatching call in the call graph nodes table
Register_CG_Node (Call_Node);
Rewrite (Call_Node, New_Call);
-- Associate the SCIL node of this dispatching call
if Generate_SCIL then
Set_SCIL_Node (SCIL_Related_Node, SCIL_Node);
end if;
-- Suppress all checks during the analysis of the expanded code to avoid
-- the generation of spurious warnings under ZFP run-time.
Analyze_And_Resolve (Call_Node, Call_Typ, Suppress => All_Checks);
end Expand_Dispatching_Call;
---------------------------------
-- Expand_Interface_Conversion --
---------------------------------
procedure Expand_Interface_Conversion (N : Node_Id) is
function Underlying_Record_Type (Typ : Entity_Id) return Entity_Id;
-- Return the underlying record type of Typ
----------------------------
-- Underlying_Record_Type --
----------------------------
function Underlying_Record_Type (Typ : Entity_Id) return Entity_Id is
E : Entity_Id := Typ;
begin
-- Handle access types
if Is_Access_Type (E) then
E := Directly_Designated_Type (E);
end if;
-- Handle class-wide types. This conversion can appear explicitly in
-- the source code. Example: I'Class (Obj)
if Is_Class_Wide_Type (E) then
E := Root_Type (E);
end if;
-- If the target type is a tagged synchronized type, the dispatch
-- table info is in the corresponding record type.
if Is_Concurrent_Type (E) then
E := Corresponding_Record_Type (E);
end if;
-- Handle private types
E := Underlying_Type (E);
-- Handle subtypes
return Base_Type (E);
end Underlying_Record_Type;
-- Local variables
Loc : constant Source_Ptr := Sloc (N);
Etyp : constant Entity_Id := Etype (N);
Operand : constant Node_Id := Expression (N);
Operand_Typ : Entity_Id := Etype (Operand);
Func : Node_Id;
Iface_Typ : constant Entity_Id := Underlying_Record_Type (Etype (N));
Iface_Tag : Entity_Id;
Is_Static : Boolean;
-- Start of processing for Expand_Interface_Conversion
begin
-- Freeze the entity associated with the target interface to have
-- available the attribute Access_Disp_Table.
Freeze_Before (N, Iface_Typ);
-- Ada 2005 (AI-345): Handle synchronized interface type derivations
if Is_Concurrent_Type (Operand_Typ) then
Operand_Typ := Base_Type (Corresponding_Record_Type (Operand_Typ));
end if;
-- No displacement of the pointer to the object needed when the type of
-- the operand is not an interface type and the interface is one of
-- its parent types (since they share the primary dispatch table).
declare
Opnd : Entity_Id := Operand_Typ;
begin
if Is_Access_Type (Opnd) then
Opnd := Designated_Type (Opnd);
end if;
Opnd := Underlying_Record_Type (Opnd);
if not Is_Interface (Opnd)
and then Is_Ancestor (Iface_Typ, Opnd, Use_Full_View => True)
then
return;
end if;
-- When the type of the operand and the target interface type match,
-- it is generally safe to skip generating code to displace the
-- pointer to the object to reference the secondary dispatch table
-- associated with the target interface type. The exception to this
-- general rule is when the underlying object of the type conversion
-- is an object built by means of a dispatching constructor (since in
-- such case the expansion of the constructor call is a direct call
-- to an object primitive, i.e. without thunks, and the expansion of
-- the constructor call adds an explicit conversion to the target
-- interface type to force the displacement of the pointer to the
-- object to reference the corresponding secondary dispatch table
-- (cf. Make_DT and Expand_Dispatching_Constructor_Call)).
-- At this stage we cannot identify whether the underlying object is
-- a BIP object and hence we cannot skip generating the code to try
-- displacing the pointer to the object. However, under configurable
-- runtime it is safe to skip generating code to displace the pointer
-- to the object, because generic dispatching constructors are not
-- supported.
if Opnd = Iface_Typ and then not RTE_Available (RE_Displace) then
return;
end if;
end;
-- Evaluate if we can statically displace the pointer to the object
declare
Opnd_Typ : constant Node_Id := Underlying_Record_Type (Operand_Typ);
begin
Is_Static :=
not Is_Interface (Opnd_Typ)
and then Interface_Present_In_Ancestor
(Typ => Opnd_Typ,
Iface => Iface_Typ)
and then (Etype (Opnd_Typ) = Opnd_Typ
or else not
Is_Variable_Size_Record (Etype (Opnd_Typ)));
end;
if not Tagged_Type_Expansion then
return;
-- A static conversion to an interface type that is not class-wide is
-- curious but legal if the interface operation is a null procedure.
-- If the operation is abstract it will be rejected later.
elsif Is_Static
and then Is_Interface (Etype (N))
and then not Is_Class_Wide_Type (Etype (N))
and then Comes_From_Source (N)
then
Rewrite (N, Unchecked_Convert_To (Etype (N), N));
Analyze (N);
return;
end if;
if not Is_Static then
-- Give error if configurable run-time and Displace not available
if not RTE_Available (RE_Displace) then
Error_Msg_CRT ("dynamic interface conversion", N);
return;
end if;
-- Handle conversion of access-to-class-wide interface types. Target
-- can be an access to an object or an access to another class-wide
-- interface (see -1- and -2- in the following example):
-- type Iface1_Ref is access all Iface1'Class;
-- type Iface2_Ref is access all Iface1'Class;
-- Acc1 : Iface1_Ref := new ...
-- Obj : Obj_Ref := Obj_Ref (Acc); -- 1
-- Acc2 : Iface2_Ref := Iface2_Ref (Acc); -- 2
if Is_Access_Type (Operand_Typ) then
Rewrite (N,
Unchecked_Convert_To (Etype (N),
Make_Function_Call (Loc,
Name => New_Occurrence_Of (RTE (RE_Displace), Loc),
Parameter_Associations => New_List (
Unchecked_Convert_To (RTE (RE_Address),
Relocate_Node (Expression (N))),
New_Occurrence_Of
(Node (First_Elmt (Access_Disp_Table (Iface_Typ))),
Loc)))));
Analyze (N);
return;
end if;
Rewrite (N,
Make_Function_Call (Loc,
Name => New_Occurrence_Of (RTE (RE_Displace), Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix => Relocate_Node (Expression (N)),
Attribute_Name => Name_Address),
New_Occurrence_Of
(Node (First_Elmt (Access_Disp_Table (Iface_Typ))),
Loc))));
Analyze (N);
-- If target is a class-wide interface, change the type of the data
-- returned by IW_Convert to indicate this is a dispatching call.
declare
New_Itype : Entity_Id;
begin
New_Itype := Create_Itype (E_Anonymous_Access_Type, N);
Set_Etype (New_Itype, New_Itype);
Set_Directly_Designated_Type (New_Itype, Etyp);
Rewrite (N,
Make_Explicit_Dereference (Loc,
Prefix =>
Unchecked_Convert_To (New_Itype, Relocate_Node (N))));
Analyze (N);
Freeze_Itype (New_Itype, N);
return;
end;
end if;
Iface_Tag := Find_Interface_Tag (Operand_Typ, Iface_Typ);
pragma Assert (Present (Iface_Tag));
-- Keep separate access types to interfaces because one internal
-- function is used to handle the null value (see following comments)
if not Is_Access_Type (Etype (N)) then
-- Statically displace the pointer to the object to reference the
-- component containing the secondary dispatch table.
Rewrite (N,
Convert_Tag_To_Interface (Class_Wide_Type (Iface_Typ),
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 : Address) return Iface_Typ is
-- type Op_Typ is access all Operand_Typ;
-- Aux : Op_Typ := To_Op_Typ (O);
-- begin
-- if O = Null_Address then
-- return null;
-- else
-- return Iface_Typ!(Aux.Iface_Tag'Address);
-- end if;
-- end Func;
declare
Desig_Typ : Entity_Id;
Fent : Entity_Id;
New_Typ_Decl : Node_Id;
Stats : List_Id;
begin
Desig_Typ := Etype (Expression (N));
if Is_Access_Type (Desig_Typ) then
Desig_Typ :=
Available_View (Directly_Designated_Type (Desig_Typ));
end if;
if Is_Concurrent_Type (Desig_Typ) then
Desig_Typ := Base_Type (Corresponding_Record_Type (Desig_Typ));
end if;
New_Typ_Decl :=
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Make_Temporary (Loc, 'T'),
Type_Definition =>
Make_Access_To_Object_Definition (Loc,
All_Present => True,
Null_Exclusion_Present => False,
Constant_Present => False,
Subtype_Indication =>
New_Occurrence_Of (Desig_Typ, Loc)));
Stats := New_List (
Make_Simple_Return_Statement (Loc,
Unchecked_Convert_To (Etype (N),
Make_Attribute_Reference (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix =>
Unchecked_Convert_To
(Defining_Identifier (New_Typ_Decl),
Make_Identifier (Loc, Name_uO)),
Selector_Name =>
New_Occurrence_Of (Iface_Tag, Loc)),
Attribute_Name => Name_Address))));
-- If the type is null-excluding, no need for the null branch.
-- Otherwise we need to check for it and return null.
if not Can_Never_Be_Null (Etype (N)) then
Stats := New_List (
Make_If_Statement (Loc,
Condition =>
Make_Op_Eq (Loc,
Left_Opnd => Make_Identifier (Loc, Name_uO),
Right_Opnd => New_Occurrence_Of
(RTE (RE_Null_Address), Loc)),
Then_Statements => New_List (
Make_Simple_Return_Statement (Loc, Make_Null (Loc))),
Else_Statements => Stats));
end if;
Fent := Make_Temporary (Loc, 'F');
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_Occurrence_Of (RTE (RE_Address), Loc))),
Result_Definition =>
New_Occurrence_Of (Etype (N), Loc)),
Declarations => New_List (New_Typ_Decl),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Stats));
-- Place function body before the expression containing the
-- conversion. We suppress all checks because the body of the
-- internally generated function already takes care of the case
-- in which the actual is null; therefore there is no need to
-- double check that the pointer is not null when the program
-- executes the alternative that performs the type conversion).
Insert_Action (N, Func, Suppress => All_Checks);
if Is_Access_Type (Etype (Expression (N))) then
-- Generate: Func (Address!(Expression))
Rewrite (N,
Make_Function_Call (Loc,
Name => New_Occurrence_Of (Fent, Loc),
Parameter_Associations => New_List (
Unchecked_Convert_To (RTE (RE_Address),
Relocate_Node (Expression (N))))));
else
-- Generate: Func (Operand_Typ!(Expression)'Address)
Rewrite (N,
Make_Function_Call (Loc,
Name => New_Occurrence_Of (Fent, Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix => Unchecked_Convert_To (Operand_Typ,
Relocate_Node (Expression (N))),
Attribute_Name => Name_Address))));
end if;
end;
end if;
Analyze (N);
end Expand_Interface_Conversion;
------------------------------
-- Expand_Interface_Actuals --
------------------------------
procedure Expand_Interface_Actuals (Call_Node : Node_Id) is
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;
Formal_DDT : Entity_Id := Empty; -- initialize to prevent warning
Actual_DDT : Entity_Id := Empty; -- initialize to prevent warning
begin
-- This subprogram is called directly from the semantics, so we need a
-- check to see whether expansion is active before proceeding.
if not Expander_Active then
return;
end if;
-- Call using access to subprogram with explicit dereference
if Nkind (Name (Call_Node)) = N_Explicit_Dereference then
Subp := Etype (Name (Call_Node));
-- Call using selected component
elsif Nkind (Name (Call_Node)) = N_Selected_Component then
Subp := Entity (Selector_Name (Name (Call_Node)));
-- Call using direct name
else
Subp := Entity (Name (Call_Node));
end if;
-- Ada 2005 (AI-251): Look for interface type formals to force "this"
-- displacement
Formal := First_Formal (Subp);
Actual := First_Actual (Call_Node);
while Present (Formal) loop
Formal_Typ := Etype (Formal);
if Has_Non_Limited_View (Formal_Typ) then
Formal_Typ := Non_Limited_View (Formal_Typ);
end if;
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);
if Has_Non_Limited_View (Formal_DDT) then
Formal_DDT := Non_Limited_View (Formal_DDT);
end if;
end if;
Actual_Typ := Etype (Actual);
if Has_Non_Limited_View (Actual_Typ) then
Actual_Typ := Non_Limited_View (Actual_Typ);
end if;
if Is_Access_Type (Actual_Typ) then
Actual_DDT := Directly_Designated_Type (Actual_Typ);
if Has_Non_Limited_View (Actual_DDT) then
Actual_DDT := Non_Limited_View (Actual_DDT);
end if;
end if;
if Is_Interface (Formal_Typ)
and then Is_Class_Wide_Type (Formal_Typ)
then
-- No need to displace the pointer if the type of the actual
-- coincides with the type of the formal.
if Actual_Typ = Formal_Typ then
null;
-- No need to displace the pointer if the interface type is a
-- parent of the type of the actual because in this case the
-- interface primitives are located in the primary dispatch table.
elsif Is_Ancestor (Formal_Typ, Actual_Typ,
Use_Full_View => True)
then
null;
-- Implicit conversion to the class-wide formal type to force the
-- displacement of the pointer.
else
-- Normally, expansion of actuals for calls to build-in-place
-- functions happens as part of Expand_Actuals, but in this
-- case the call will be wrapped in a conversion and soon after
-- expanded further to handle the displacement for a class-wide
-- interface conversion, so if this is a BIP call then we need
-- to handle it now.
if Is_Build_In_Place_Function_Call (Actual) then
Make_Build_In_Place_Call_In_Anonymous_Context (Actual);
end if;
Conversion := Convert_To (Formal_Typ, Relocate_Node (Actual));
Rewrite (Actual, Conversion);
Analyze_And_Resolve (Actual, Formal_Typ);
end if;
-- Access to class-wide interface type
elsif Is_Access_Type (Formal_Typ)
and then Is_Interface (Formal_DDT)
and then Is_Class_Wide_Type (Formal_DDT)
and then Interface_Present_In_Ancestor
(Typ => Actual_DDT,
Iface => Etype (Formal_DDT))
then
-- Handle attributes 'Access and 'Unchecked_Access
if Nkind (Actual) = N_Attribute_Reference
and then
(Attribute_Name (Actual) = Name_Access
or else Attribute_Name (Actual) = Name_Unchecked_Access)
then
-- This case must have been handled by the analysis and
-- expansion of 'Access. The only exception is when types
-- match and no further expansion is required.
pragma Assert (Base_Type (Etype (Prefix (Actual)))
= Base_Type (Formal_DDT));
null;
-- No need to displace the pointer if the type of the actual
-- coincides with the type of the formal.
elsif Actual_DDT = Formal_DDT then
null;
-- No need to displace the pointer if the interface type is
-- a parent of the type of the actual because in this case the
-- interface primitives are located in the primary dispatch table.
elsif Is_Ancestor (Formal_DDT, Actual_DDT,
Use_Full_View => True)
then
null;
else
Actual_Dup := Relocate_Node (Actual);
if From_Limited_With (Actual_Typ) then
-- If the type of the actual parameter comes from a limited
-- with_clause and the nonlimited view is already available,
-- we replace the anonymous access type by a duplicate
-- declaration whose designated type is the nonlimited view.
if Has_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);
end if;
end if;
Conversion := Convert_To (Formal_Typ, Actual_Dup);
Rewrite (Actual, Conversion);
Analyze_And_Resolve (Actual, Formal_Typ);
end if;
end if;
Next_Actual (Actual);
Next_Formal (Formal);
end loop;
end Expand_Interface_Actuals;
----------------------------
-- Expand_Interface_Thunk --
----------------------------
procedure Expand_Interface_Thunk
(Prim : Node_Id;
Thunk_Id : out Entity_Id;
Thunk_Code : out Node_Id;
Iface : Entity_Id)
is
Loc : constant Source_Ptr := Sloc (Prim);
Actuals : constant List_Id := New_List;
Decl : constant List_Id := New_List;
Formals : constant List_Id := New_List;
Target : constant Entity_Id := Ultimate_Alias (Prim);
Decl_1 : Node_Id;
Decl_2 : Node_Id;
Expr : Node_Id;
Formal : Node_Id;
Ftyp : Entity_Id;
Iface_Formal : Node_Id := Empty; -- initialize to prevent warning
Is_Predef_Op : constant Boolean :=
Is_Predefined_Dispatching_Operation (Prim)
or else Is_Predefined_Dispatching_Operation (Target);
New_Arg : Node_Id;
Offset_To_Top : Node_Id;
Target_Formal : Entity_Id;
begin
Thunk_Id := Empty;
Thunk_Code := Empty;
-- No thunk needed if the primitive has been eliminated
if Is_Eliminated (Target) then
return;
-- In case of primitives that are functions without formals and a
-- controlling result there is no need to build the thunk.
elsif not Present (First_Formal (Target)) then
pragma Assert (Ekind (Target) = E_Function
and then Has_Controlling_Result (Target));
return;
end if;
-- Duplicate the formals of the Target primitive. In the thunk, the type
-- of the controlling formal is the covered interface type (instead of
-- the target tagged type). Done to avoid problems with discriminated
-- tagged types because, if the controlling type has discriminants with
-- default values, then the type conversions done inside the body of
-- the thunk (after the displacement of the pointer to the base of the
-- actual object) generate code that modify its contents.
-- Note: This special management is not done for predefined primitives
-- because they don't have available the Interface_Alias attribute (see
-- Sem_Ch3.Add_Internal_Interface_Entities).
if not Is_Predef_Op then
Iface_Formal := First_Formal (Interface_Alias (Prim));
end if;
Formal := First_Formal (Target);
while Present (Formal) loop
Ftyp := Etype (Formal);
-- Use the interface type as the type of the controlling formal (see
-- comment above).
if not Is_Controlling_Formal (Formal) then
Ftyp := Etype (Formal);
Expr := New_Copy_Tree (Expression (Parent (Formal)));
-- For predefined primitives the controlling type of the thunk is
-- the interface type passed by the caller (since they don't have
-- available the Interface_Alias attribute; see comment above).
elsif Is_Predef_Op then
Ftyp := Iface;
Expr := Empty;
else
Ftyp := Etype (Iface_Formal);
Expr := Empty;
-- Sanity check performed to ensure the proper controlling type
-- when the thunk has exactly one controlling parameter and it
-- comes first. In such case the GCC backend reuses the C++
-- thunks machinery which perform a computation equivalent to
-- the code generated by the expander; for other cases the GCC
-- backend translates the expanded code unmodified. However, as
-- a generalization, the check is performed for all controlling
-- types.
if Is_Access_Type (Ftyp) then
pragma Assert (Base_Type (Designated_Type (Ftyp)) = Iface);
null;
else
Ftyp := Base_Type (Ftyp);
pragma Assert (Ftyp = Iface);
end if;
end if;
Append_To (Formals,
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Sloc (Formal),
Chars => Chars (Formal)),
In_Present => In_Present (Parent (Formal)),
Out_Present => Out_Present (Parent (Formal)),
Parameter_Type => New_Occurrence_Of (Ftyp, Loc),
Expression => Expr));
if not Is_Predef_Op then
Next_Formal (Iface_Formal);
end if;
Next_Formal (Formal);
end loop;
Target_Formal := First_Formal (Target);
Formal := First (Formals);
while Present (Formal) loop
-- If the parent is a constrained discriminated type, then the
-- primitive operation will have been defined on a first subtype.
-- For proper matching with controlling type, use base type.
if Ekind (Target_Formal) = E_In_Parameter
and then Ekind (Etype (Target_Formal)) = E_Anonymous_Access_Type
then
Ftyp :=
Base_Type (Directly_Designated_Type (Etype (Target_Formal)));
else
Ftyp := Base_Type (Etype (Target_Formal));
end if;
-- For concurrent types, the relevant information is found in the
-- Corresponding_Record_Type, rather than the type entity itself.
if Is_Concurrent_Type (Ftyp) then
Ftyp := Corresponding_Record_Type (Ftyp);
end if;
if Ekind (Target_Formal) = E_In_Parameter
and then Ekind (Etype (Target_Formal)) = E_Anonymous_Access_Type
and then Is_Controlling_Formal (Target_Formal)
then
-- Generate:
-- type T is access all <<type of the target formal>>
-- S : Storage_Offset := Storage_Offset!(Formal)
-- + Offset_To_Top (address!(Formal))
Decl_2 :=
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Make_Temporary (Loc, 'T'),
Type_Definition =>
Make_Access_To_Object_Definition (Loc,
All_Present => True,
Null_Exclusion_Present => False,
Constant_Present => False,
Subtype_Indication =>
New_Occurrence_Of (Ftyp, Loc)));
New_Arg :=
Unchecked_Convert_To (RTE (RE_Address),
New_Occurrence_Of (Defining_Identifier (Formal), Loc));
if not RTE_Available (RE_Offset_To_Top) then
Offset_To_Top :=
Build_Offset_To_Top (Loc, New_Arg);
else
Offset_To_Top :=
Make_Function_Call (Loc,
Name => New_Occurrence_Of (RTE (RE_Offset_To_Top), Loc),
Parameter_Associations => New_List (New_Arg));
end if;
Decl_1 :=
Make_Object_Declaration (Loc,
Defining_Identifier => Make_Temporary (Loc, 'S'),
Constant_Present => True,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Storage_Offset), Loc),
Expression =>
Make_Op_Add (Loc,
Left_Opnd =>
Unchecked_Convert_To
(RTE (RE_Storage_Offset),
New_Occurrence_Of
(Defining_Identifier (Formal), Loc)),
Right_Opnd =>
Offset_To_Top));
Append_To (Decl, Decl_2);
Append_To (Decl, Decl_1);
-- Reference the new actual. Generate:
-- T!(S)
Append_To (Actuals,
Unchecked_Convert_To
(Defining_Identifier (Decl_2),
New_Occurrence_Of (Defining_Identifier (Decl_1), Loc)));
elsif Is_Controlling_Formal (Target_Formal) then
-- Generate:
-- S1 : Storage_Offset := Storage_Offset!(Formal'Address)
-- + Offset_To_Top (Formal'Address)
-- S2 : Addr_Ptr := Addr_Ptr!(S1)
New_Arg :=
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Defining_Identifier (Formal), Loc),
Attribute_Name =>
Name_Address);
if not RTE_Available (RE_Offset_To_Top) then
Offset_To_Top :=
Build_Offset_To_Top (Loc, New_Arg);
else
Offset_To_Top :=
Make_Function_Call (Loc,
Name => New_Occurrence_Of (RTE (RE_Offset_To_Top), Loc),
Parameter_Associations => New_List (New_Arg));
end if;
Decl_1 :=
Make_Object_Declaration (Loc,
Defining_Identifier => Make_Temporary (Loc, 'S'),
Constant_Present => True,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Storage_Offset), Loc),
Expression =>
Make_Op_Add (Loc,
Left_Opnd =>
Unchecked_Convert_To
(RTE (RE_Storage_Offset),
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of
(Defining_Identifier (Formal), Loc),
Attribute_Name => Name_Address)),
Right_Opnd =>
Offset_To_Top));
Decl_2 :=
Make_Object_Declaration (Loc,
Defining_Identifier => Make_Temporary (Loc, 'S'),
Constant_Present => True,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Addr_Ptr), Loc),
Expression =>
Unchecked_Convert_To
(RTE (RE_Addr_Ptr),
New_Occurrence_Of (Defining_Identifier (Decl_1), Loc)));
Append_To (Decl, Decl_1);
Append_To (Decl, Decl_2);
-- Reference the new actual, generate:
-- Target_Formal (S2.all)
Append_To (Actuals,
Unchecked_Convert_To (Ftyp,
Make_Explicit_Dereference (Loc,
New_Occurrence_Of (Defining_Identifier (Decl_2), Loc))));
-- Ensure proper matching of access types. Required to avoid
-- reporting spurious errors.
elsif Is_Access_Type (Etype (Target_Formal)) then
Append_To (Actuals,
Unchecked_Convert_To (Base_Type (Etype (Target_Formal)),
New_Occurrence_Of (Defining_Identifier (Formal), Loc)));
-- No special management required for this actual
else
Append_To (Actuals,
New_Occurrence_Of (Defining_Identifier (Formal), Loc));
end if;
Next_Formal (Target_Formal);
Next (Formal);
end loop;
Thunk_Id := Make_Temporary (Loc, 'T');
-- Note: any change to this symbol name needs to be coordinated
-- with GNATcoverage, as that tool relies on it to identify
-- thunks and exclude them from source coverage analysis.
Mutate_Ekind (Thunk_Id, Ekind (Prim));
Set_Is_Thunk (Thunk_Id);
Set_Convention (Thunk_Id, Convention (Prim));
Set_Needs_Debug_Info (Thunk_Id, Needs_Debug_Info (Target));
Set_Thunk_Entity (Thunk_Id, Target);
-- Procedure case
if Ekind (Target) = E_Procedure then
Thunk_Code :=
Make_Subprogram_Body (Loc,
Specification =>
Make_Procedure_Specification (Loc,
Defining_Unit_Name => Thunk_Id,
Parameter_Specifications => Formals),
Declarations => Decl,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (Target, Loc),
Parameter_Associations => Actuals))));
-- Function case
else pragma Assert (Ekind (Target) = E_Function);
declare
Result_Def : Node_Id;
Call_Node : Node_Id;
begin
Call_Node :=
Make_Function_Call (Loc,
Name => New_Occurrence_Of (Target, Loc),
Parameter_Associations => Actuals);
if not Is_Interface (Etype (Prim)) then
Result_Def := New_Copy (Result_Definition (Parent (Target)));
-- Thunk of function returning a class-wide interface object. No
-- extra displacement needed since the displacement is generated
-- in the return statement of Prim. Example:
-- type Iface is interface ...
-- function F (O : Iface) return Iface'Class;
-- type T is new ... and Iface with ...
-- function F (O : T) return Iface'Class;
elsif Is_Class_Wide_Type (Etype (Prim)) then
Result_Def := New_Occurrence_Of (Etype (Prim), Loc);
-- Thunk of function returning an interface object. Displacement
-- needed. Example:
-- type Iface is interface ...
-- function F (O : Iface) return Iface;
-- type T is new ... and Iface with ...
-- function F (O : T) return T;
else
Result_Def :=
New_Occurrence_Of (Class_Wide_Type (Etype (Prim)), Loc);
-- Adding implicit conversion to force the displacement of
-- the pointer to the object to reference the corresponding
-- secondary dispatch table.
Call_Node :=
Make_Type_Conversion (Loc,
Subtype_Mark =>
New_Occurrence_Of (Class_Wide_Type (Etype (Prim)), Loc),
Expression => Relocate_Node (Call_Node));
end if;
Thunk_Code :=
Make_Subprogram_Body (Loc,
Specification =>
Make_Function_Specification (Loc,
Defining_Unit_Name => Thunk_Id,
Parameter_Specifications => Formals,
Result_Definition => Result_Def),
Declarations => Decl,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Simple_Return_Statement (Loc, Call_Node))));
end;
end if;
end Expand_Interface_Thunk;
--------------------------
-- Has_CPP_Constructors --
--------------------------
function Has_CPP_Constructors (Typ : Entity_Id) return Boolean is
E : Entity_Id;
begin
-- Look for the constructor entities
E := Next_Entity (Typ);
while Present (E) loop
if Ekind (E) = E_Function and then Is_Constructor (E) then
return True;
end if;
Next_Entity (E);
end loop;
return False;
end Has_CPP_Constructors;
------------
-- Has_DT --
------------
function Has_DT (Typ : Entity_Id) return Boolean is
begin
return not Is_Interface (Typ)
and then not Restriction_Active (No_Dispatching_Calls);
end Has_DT;
----------------------------------
-- Is_Expanded_Dispatching_Call --
----------------------------------
function Is_Expanded_Dispatching_Call (N : Node_Id) return Boolean is
begin
return Nkind (N) in N_Subprogram_Call
and then Nkind (Name (N)) = N_Explicit_Dereference
and then Is_Dispatch_Table_Entity (Etype (Name (N)));
end Is_Expanded_Dispatching_Call;
-------------------------------------
-- Is_Predefined_Dispatching_Alias --
-------------------------------------
function Is_Predefined_Dispatching_Alias (Prim : Entity_Id) return Boolean
is
begin
return not Is_Predefined_Dispatching_Operation (Prim)
and then Present (Alias (Prim))
and then Is_Predefined_Dispatching_Operation (Ultimate_Alias (Prim));
end Is_Predefined_Dispatching_Alias;
----------------------------------------
-- Make_Disp_Asynchronous_Select_Body --
----------------------------------------
-- For interface types, generate:
-- procedure _Disp_Asynchronous_Select
-- (T : in out <Typ>;
-- S : Integer;
-- P : System.Address;
-- B : out System.Storage_Elements.Dummy_Communication_Block;
-- F : out Boolean)
-- is
-- begin
-- F := False;
-- C := Ada.Tags.POK_Function;
-- end _Disp_Asynchronous_Select;
-- For protected types, generate:
-- procedure _Disp_Asynchronous_Select
-- (T : in out <Typ>;
-- S : Integer;
-- P : System.Address;
-- B : out System.Storage_Elements.Dummy_Communication_Block;
-- F : out Boolean)
-- is
-- I : Integer :=
-- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
-- Bnn : System.Tasking.Protected_Objects.Operations.
-- Communication_Block;
-- begin
-- System.Tasking.Protected_Objects.Operations.Protected_Entry_Call
-- (T._object'Access,
-- System.Tasking.Protected_Objects.Protected_Entry_Index (I),
-- P,
-- System.Tasking.Asynchronous_Call,
-- Bnn);
-- B := System.Storage_Elements.Dummy_Communication_Block (Bnn);
-- end _Disp_Asynchronous_Select;
-- For task types, generate:
-- procedure _Disp_Asynchronous_Select
-- (T : in out <Typ>;
-- S : Integer;
-- P : System.Address;
-- B : out System.Storage_Elements.Dummy_Communication_Block;
-- F : out Boolean)
-- is
-- I : Integer :=
-- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
-- begin
-- System.Tasking.Rendezvous.Task_Entry_Call
-- (T._task_id,
-- System.Tasking.Task_Entry_Index (I),
-- P,
-- System.Tasking.Asynchronous_Call,
-- F);
-- end _Disp_Asynchronous_Select;
function Make_Disp_Asynchronous_Select_Body
(Typ : Entity_Id) return Node_Id
is
Com_Block : Entity_Id;
Conc_Typ : Entity_Id := Empty;
Decls : constant List_Id := New_List;
Loc : constant Source_Ptr := Sloc (Typ);
Obj_Ref : Node_Id;
Stmts : constant List_Id := New_List;
Tag_Node : Node_Id;
begin
pragma Assert (not Restriction_Active (No_Dispatching_Calls));
-- Null body is generated for interface types
if Is_Interface (Typ) then
return
Make_Subprogram_Body (Loc,
Specification =>
Make_Disp_Asynchronous_Select_Spec (Typ),
Declarations => New_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
New_List (
Make_Assignment_Statement (Loc,
Name => Make_Identifier (Loc, Name_uF),
Expression => New_Occurrence_Of (Standard_False, Loc)))));
end if;
if Is_Concurrent_Record_Type (Typ) then
Conc_Typ := Corresponding_Concurrent_Type (Typ);
-- Generate:
-- I : Integer :=
-- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag! (<type>VP), S);
-- where I will be used to capture the entry index of the primitive
-- wrapper at position S.
if Tagged_Type_Expansion then
Tag_Node :=
Unchecked_Convert_To (RTE (RE_Tag),
New_Occurrence_Of
(Node (First_Elmt (Access_Disp_Table (Typ))), Loc));
else
Tag_Node :=
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Typ, Loc),
Attribute_Name => Name_Tag);
end if;
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uI),
Object_Definition =>
New_Occurrence_Of (Standard_Integer, Loc),
Expression =>
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Get_Entry_Index), Loc),
Parameter_Associations =>
New_List (Tag_Node, Make_Identifier (Loc, Name_uS)))));
if Ekind (Conc_Typ) = E_Protected_Type then
-- Generate:
-- Bnn : Communication_Block;
Com_Block := Make_Temporary (Loc, 'B');
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Com_Block,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Communication_Block), Loc)));
-- Build T._object'Access for calls below
Obj_Ref :=
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Unchecked_Access,
Prefix =>
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_uT),
Selector_Name => Make_Identifier (Loc, Name_uObject)));
case Corresponding_Runtime_Package (Conc_Typ) is
when System_Tasking_Protected_Objects_Entries =>
-- Generate:
-- Protected_Entry_Call
-- (T._object'Access, -- Object
-- Protected_Entry_Index! (I), -- E
-- P, -- Uninterpreted_Data
-- Asynchronous_Call, -- Mode
-- Bnn); -- Communication_Block
-- where T is the protected object, I is the entry index, P
-- is the wrapped parameters and B is the name of the
-- communication block.
Append_To (Stmts,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Protected_Entry_Call), Loc),
Parameter_Associations =>
New_List (
Obj_Ref,
Unchecked_Convert_To ( -- entry index
RTE (RE_Protected_Entry_Index),
Make_Identifier (Loc, Name_uI)),
Make_Identifier (Loc, Name_uP), -- parameter block
New_Occurrence_Of -- Asynchronous_Call
(RTE (RE_Asynchronous_Call), Loc),
New_Occurrence_Of -- comm block
(Com_Block, Loc))));
when others =>
raise Program_Error;
end case;
-- Generate:
-- B := Dummy_Communication_Block (Bnn);
Append_To (Stmts,
Make_Assignment_Statement (Loc,
Name => Make_Identifier (Loc, Name_uB),
Expression =>
Unchecked_Convert_To
(RTE (RE_Dummy_Communication_Block),
New_Occurrence_Of (Com_Block, Loc))));
-- Generate:
-- F := False;
Append_To (Stmts,
Make_Assignment_Statement (Loc,
Name => Make_Identifier (Loc, Name_uF),
Expression => New_Occurrence_Of (Standard_False, Loc)));
else
pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
-- Generate:
-- Task_Entry_Call
-- (T._task_id, -- Acceptor
-- Task_Entry_Index! (I), -- E
-- P, -- Uninterpreted_Data
-- Asynchronous_Call, -- Mode
-- F); -- Rendezvous_Successful
-- where T is the task object, I is the entry index, P is the
-- wrapped parameters and F is the status flag.
Append_To (Stmts,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (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)),
Unchecked_Convert_To ( -- entry index
RTE (RE_Task_Entry_Index),
Make_Identifier (Loc, Name_uI)),
Make_Identifier (Loc, Name_uP), -- parameter block
New_Occurrence_Of -- Asynchronous_Call
(RTE (RE_Asynchronous_Call), Loc),
Make_Identifier (Loc, Name_uF)))); -- status flag
end if;
else
-- Ensure that the statements list is non-empty
Append_To (Stmts,
Make_Assignment_Statement (Loc,
Name => Make_Identifier (Loc, Name_uF),
Expression => New_Occurrence_Of (Standard_False, 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);
B_Id : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
Def_Id : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Name_uDisp_Asynchronous_Select);
Params : constant List_Id := New_List;
begin
pragma Assert (not Restriction_Active (No_Dispatching_Calls));
-- T : in out Typ; -- Object parameter
-- S : Integer; -- Primitive operation slot
-- P : Address; -- Wrapped parameters
-- B : out Dummy_Communication_Block; -- Communication block dummy
-- F : out Boolean; -- Status flag
-- The B parameter may be left uninitialized
Set_Warnings_Off (B_Id);
Append_List_To (Params, New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_uT),
Parameter_Type => New_Occurrence_Of (Typ, Loc),
In_Present => True,
Out_Present => True),
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_uS),
Parameter_Type => New_Occurrence_Of (Standard_Integer, Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_uP),
Parameter_Type => New_Occurrence_Of (RTE (RE_Address), Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => B_Id,
Parameter_Type =>
New_Occurrence_Of (RTE (RE_Dummy_Communication_Block), Loc),
Out_Present => True),
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_uF),
Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc),
Out_Present => True)));
return
Make_Procedure_Specification (Loc,
Defining_Unit_Name => Def_Id,
Parameter_Specifications => Params);
end Make_Disp_Asynchronous_Select_Spec;
---------------------------------------
-- Make_Disp_Conditional_Select_Body --
---------------------------------------
-- For interface types, generate:
-- procedure _Disp_Conditional_Select
-- (T : in out <Typ>;
-- S : Integer;
-- P : System.Address;
-- C : out Ada.Tags.Prim_Op_Kind;
-- F : out Boolean)
-- is
-- begin
-- F := False;
-- C := Ada.Tags.POK_Function;
-- end _Disp_Conditional_Select;
-- For protected types, generate:
-- procedure _Disp_Conditional_Select
-- (T : in out <Typ>;
-- S : Integer;
-- P : System.Address;
-- C : out Ada.Tags.Prim_Op_Kind;
-- F : out Boolean)
-- is
-- I : Integer;
-- Bnn : System.Tasking.Protected_Objects.Operations.
-- Communication_Block;
-- begin
-- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag (<Typ>VP, S));
-- if C = Ada.Tags.POK_Procedure
-- or else C = Ada.Tags.POK_Protected_Procedure
-- or else C = Ada.Tags.POK_Task_Procedure
-- then
-- F := True;
-- return;
-- end if;
-- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
-- System.Tasking.Protected_Objects.Operations.Protected_Entry_Call
-- (T.object'Access,
-- System.Tasking.Protected_Objects.Protected_Entry_Index (I),
-- P,
-- System.Tasking.Conditional_Call,
-- Bnn);
-- F := not Cancelled (Bnn);
-- end _Disp_Conditional_Select;
-- For task types, generate:
-- procedure _Disp_Conditional_Select
-- (T : in out <Typ>;
-- S : Integer;
-- P : System.Address;
-- C : out Ada.Tags.Prim_Op_Kind;
-- F : out Boolean)
-- is
-- I : Integer;
-- begin
-- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
-- System.Tasking.Rendezvous.Task_Entry_Call
-- (T._task_id,
-- System.Tasking.Task_Entry_Index (I),
-- P,
-- System.Tasking.Conditional_Call,
-- F);
-- end _Disp_Conditional_Select;
function Make_Disp_Conditional_Select_Body
(Typ : Entity_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Typ);
Blk_Nam : Entity_Id;
Conc_Typ : Entity_Id := Empty;
Decls : constant List_Id := New_List;
Obj_Ref : Node_Id;
Stmts : constant List_Id := New_List;
Tag_Node : Node_Id;
begin
pragma Assert (not Restriction_Active (No_Dispatching_Calls));
-- Null body is generated for interface types
if Is_Interface (Typ) then
return
Make_Subprogram_Body (Loc,
Specification =>
Make_Disp_Conditional_Select_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_uF),
Expression => New_Occurrence_Of (Standard_False, Loc)))));
end if;
if Is_Concurrent_Record_Type (Typ) then
Conc_Typ := Corresponding_Concurrent_Type (Typ);
-- 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_Occurrence_Of (Standard_Integer, Loc)));
-- Generate:
-- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.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;
Build_Common_Dispatching_Select_Statements (Typ, Stmts);
-- Generate:
-- Bnn : Communication_Block;
-- where Bnn is the name of the communication block used in the
-- call to Protected_Entry_Call.
Blk_Nam := Make_Temporary (Loc, 'B');
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Blk_Nam,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Communication_Block), Loc)));
-- Generate:
-- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag! (<type>VP), S);
-- I is the entry index and S is the dispatch table slot
if Tagged_Type_Expansion then
Tag_Node :=
Unchecked_Convert_To (RTE (RE_Tag),
New_Occurrence_Of
(Node (First_Elmt (Access_Disp_Table (Typ))), Loc));
else
Tag_Node :=
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Typ, Loc),
Attribute_Name => Name_Tag);
end if;
Append_To (Stmts,
Make_Assignment_Statement (Loc,
Name => Make_Identifier (Loc, Name_uI),
Expression =>
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Get_Entry_Index), Loc),
Parameter_Associations => New_List (
Tag_Node,
Make_Identifier (Loc, Name_uS)))));
if Ekind (Conc_Typ) = E_Protected_Type then
Obj_Ref := -- T._object'Access
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Unchecked_Access,
Prefix =>
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_uT),
Selector_Name => Make_Identifier (Loc, Name_uObject)));
case Corresponding_Runtime_Package (Conc_Typ) is
when System_Tasking_Protected_Objects_Entries =>
-- Generate:
-- Protected_Entry_Call
-- (T._object'Access, -- Object
-- Protected_Entry_Index! (I), -- E
-- P, -- Uninterpreted_Data
-- Conditional_Call, -- Mode
-- Bnn); -- Block
-- 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_Occurrence_Of (RTE (RE_Protected_Entry_Call), Loc),
Parameter_Associations => New_List (
Obj_Ref,
Unchecked_Convert_To ( -- entry index
RTE (RE_Protected_Entry_Index),
Make_Identifier (Loc, Name_uI)),
Make_Identifier (Loc, Name_uP), -- parameter block
New_Occurrence_Of -- Conditional_Call
(RTE (RE_Conditional_Call), Loc),
New_Occurrence_Of -- Bnn
(Blk_Nam, Loc))));
when System_Tasking_Protected_Objects_Single_Entry =>
-- If we are compiling for a restricted run-time, the call
-- uses the simpler form.
Append_To (Stmts,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of
(RTE (RE_Protected_Single_Entry_Call), Loc),
Parameter_Associations => New_List (
Obj_Ref,
Make_Attribute_Reference (Loc,
Prefix => Make_Identifier (Loc, Name_uP),
Attribute_Name => Name_Address),
New_Occurrence_Of
(RTE (RE_Conditional_Call), Loc))));
when others =>
raise Program_Error;
end case;
-- Generate:
-- F := not Cancelled (Bnn);
-- where F is the success flag. The status of Cancelled is negated
-- in order to match the behavior 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_Occurrence_Of (RTE (RE_Cancelled), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Blk_Nam, Loc))))));
else
pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
-- Generate:
-- Task_Entry_Call
-- (T._task_id, -- Acceptor
-- Task_Entry_Index! (I), -- E
-- P, -- Uninterpreted_Data
-- Conditional_Call, -- Mode
-- F); -- Rendezvous_Successful
-- 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_Occurrence_Of (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)),
Unchecked_Convert_To ( -- entry index
RTE (RE_Task_Entry_Index),
Make_Identifier (Loc, Name_uI)),
Make_Identifier (Loc, Name_uP), -- parameter block
New_Occurrence_Of -- Conditional_Call
(RTE (RE_Conditional_Call), Loc),
Make_Identifier (Loc, Name_uF)))); -- status flag
end if;
else
-- Initialize out parameters
Append_To (Stmts,
Make_Assignment_Statement (Loc,
Name => Make_Identifier (Loc, Name_uF),
Expression => New_Occurrence_Of (Standard_False, Loc)));
Append_To (Stmts,
Make_Assignment_Statement (Loc,
Name => Make_Identifier (Loc, Name_uC),
Expression => New_Occurrence_Of (RTE (RE_POK_Function), 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);
Def_Id : constant Node_Id :=
Make_Defining_Identifier (Loc,
Name_uDisp_Conditional_Select);
Params : constant List_Id := New_List;
begin
pragma Assert (not Restriction_Active (No_Dispatching_Calls));
-- T : in out Typ; -- Object parameter
-- S : Integer; -- Primitive operation slot
-- P : Address; -- Wrapped parameters
-- C : out Prim_Op_Kind; -- Call kind
-- F : out Boolean; -- Status flag
Append_List_To (Params, New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_uT),
Parameter_Type => New_Occurrence_Of (Typ, Loc),
In_Present => True,
Out_Present => True),
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_uS),
Parameter_Type => New_Occurrence_Of (Standard_Integer, Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_uP),
Parameter_Type => New_Occurrence_Of (RTE (RE_Address), Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_uC),
Parameter_Type =>
New_Occurrence_Of (RTE (RE_Prim_Op_Kind), Loc),
Out_Present => True),
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_uF),
Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc),
Out_Present => True)));
return
Make_Procedure_Specification (Loc,
Defining_Unit_Name => Def_Id,
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);
Tag_Node : Node_Id;
begin
pragma Assert (not Restriction_Active (No_Dispatching_Calls));
if Is_Interface (Typ) then
return
Make_Subprogram_Body (Loc,
Specification =>
Make_Disp_Get_Prim_Op_Kind_Spec (Typ),
Declarations => New_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
New_List (Make_Null_Statement (Loc))));
end if;
-- 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.
if Tagged_Type_Expansion then
Tag_Node :=
Unchecked_Convert_To (RTE (RE_Tag),
New_Occurrence_Of
(Node (First_Elmt (Access_Disp_Table (Typ))), Loc));
else
Tag_Node :=
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Typ, Loc),
Attribute_Name => Name_Tag);
end if;
return
Make_Subprogram_Body (Loc,
Specification =>
Make_Disp_Get_Prim_Op_Kind_Spec (Typ),
Declarations => New_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
New_List (
Make_Assignment_Statement (Loc,
Name => Make_Identifier (Loc, Name_uC),
Expression =>
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Get_Prim_Op_Kind), Loc),
Parameter_Associations => New_List (
Tag_Node,
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);
Def_Id : constant Node_Id :=
Make_Defining_Identifier (Loc, Name_uDisp_Get_Prim_Op_Kind);
Params : constant List_Id := New_List;
begin
pragma Assert (not Restriction_Active (No_Dispatching_Calls));
-- T : in out Typ; -- Object parameter
-- S : Integer; -- Primitive operation slot
-- C : out Prim_Op_Kind; -- Call kind
Append_List_To (Params, New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_uT),
Parameter_Type => New_Occurrence_Of (Typ, Loc),
In_Present => True,
Out_Present => True),
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_uS),
Parameter_Type => New_Occurrence_Of (Standard_Integer, Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_uC),
Parameter_Type =>
New_Occurrence_Of (RTE (RE_Prim_Op_Kind), Loc),
Out_Present => True)));
return
Make_Procedure_Specification (Loc,
Defining_Unit_Name => Def_Id,
Parameter_Specifications => Params);
end Make_Disp_Get_Prim_Op_Kind_Spec;
--------------------------------
-- Make_Disp_Get_Task_Id_Body --
--------------------------------
function Make_Disp_Get_Task_Id_Body
(Typ : Entity_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Typ);
Ret : Node_Id;
begin
pragma Assert (not Restriction_Active (No_Dispatching_Calls));
if Is_Concurrent_Record_Type (Typ)
and then Ekind (Corresponding_Concurrent_Type (Typ)) = E_Task_Type
then
-- Generate:
-- return To_Address (_T._task_id);
Ret :=
Make_Simple_Return_Statement (Loc,
Expression =>
Unchecked_Convert_To
(RTE (RE_Address),
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_uT),
Selector_Name => Make_Identifier (Loc, Name_uTask_Id))));
-- A null body is constructed for non-task types
else
-- Generate:
-- return Null_Address;
Ret :=
Make_Simple_Return_Statement (Loc,
Expression => New_Occurrence_Of (RTE (RE_Null_Address), Loc));
end if;
return
Make_Subprogram_Body (Loc,
Specification => Make_Disp_Get_Task_Id_Spec (Typ),
Declarations => New_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, New_List (Ret)));
end Make_Disp_Get_Task_Id_Body;
--------------------------------
-- Make_Disp_Get_Task_Id_Spec --
--------------------------------
function Make_Disp_Get_Task_Id_Spec
(Typ : Entity_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Typ);
begin
pragma Assert (not Restriction_Active (No_Dispatching_Calls));
return
Make_Function_Specification (Loc,
Defining_Unit_Name =>
Make_Defining_Identifier (Loc, Name_uDisp_Get_Task_Id),
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_uT),
Parameter_Type => New_Occurrence_Of (Typ, Loc))),
Result_Definition =>
New_Occurrence_Of (RTE (RE_Address), Loc));
end Make_Disp_Get_Task_Id_Spec;
----------------------------
-- Make_Disp_Requeue_Body --
----------------------------
function Make_Disp_Requeue_Body
(Typ : Entity_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Typ);
Conc_Typ : Entity_Id := Empty;
Stmts : constant List_Id := New_List;
begin
pragma Assert (not Restriction_Active (No_Dispatching_Calls));
-- Null body is generated for interface types and non-concurrent
-- tagged types.
if Is_Interface (Typ)
or else not Is_Concurrent_Record_Type (Typ)
then
return
Make_Subprogram_Body (Loc,
Specification => Make_Disp_Requeue_Spec (Typ),
Declarations => No_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
New_List (Make_Null_Statement (Loc))));
end if;
Conc_Typ := Corresponding_Concurrent_Type (Typ);
if Ekind (Conc_Typ) = E_Protected_Type then
-- Generate statements:
-- if F then
-- System.Tasking.Protected_Objects.Operations.
-- Requeue_Protected_Entry
-- (Protection_Entries_Access (P),
-- O._object'Unchecked_Access,
-- Protected_Entry_Index (I),
-- A);
-- else
-- System.Tasking.Protected_Objects.Operations.
-- Requeue_Task_To_Protected_Entry
-- (O._object'Unchecked_Access,
-- Protected_Entry_Index (I),
-- A);
-- end if;
if Restriction_Active (No_Entry_Queue) then
Append_To (Stmts, Make_Null_Statement (Loc));
else
Append_To (Stmts,
Make_If_Statement (Loc,
Condition => Make_Identifier (Loc, Name_uF),
Then_Statements =>
New_List (
-- Call to Requeue_Protected_Entry
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of
(RTE (RE_Requeue_Protected_Entry), Loc),
Parameter_Associations =>
New_List (
Unchecked_Convert_To ( -- PEA (P)
RTE (RE_Protection_Entries_Access),
Make_Identifier (Loc, Name_uP)),
Make_Attribute_Reference (Loc, -- O._object'Acc
Attribute_Name =>
Name_Unchecked_Access,
Prefix =>
Make_Selected_Component (Loc,
Prefix =>
Make_Identifier (Loc, Name_uO),
Selector_Name =>
Make_Identifier (Loc, Name_uObject))),
Unchecked_Convert_To ( -- entry index
RTE (RE_Protected_Entry_Index),
Make_Identifier (Loc, Name_uI)),
Make_Identifier (Loc, Name_uA)))), -- abort status
Else_Statements =>
New_List (
-- Call to Requeue_Task_To_Protected_Entry
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of
(RTE (RE_Requeue_Task_To_Protected_Entry), Loc),
Parameter_Associations =>
New_List (
Make_Attribute_Reference (Loc, -- O._object'Acc
Attribute_Name => Name_Unchecked_Access,
Prefix =>
Make_Selected_Component (Loc,
Prefix =>
Make_Identifier (Loc, Name_uO),
Selector_Name =>
Make_Identifier (Loc, Name_uObject))),
Unchecked_Convert_To ( -- entry index
RTE (RE_Protected_Entry_Index),
Make_Identifier (Loc, Name_uI)),
Make_Identifier (Loc, Name_uA)))))); -- abort status
end if;
else
pragma Assert (Is_Task_Type (Conc_Typ));
-- Generate:
-- if F then
-- System.Tasking.Rendezvous.Requeue_Protected_To_Task_Entry
-- (Protection_Entries_Access (P),
-- O._task_id,
-- Task_Entry_Index (I),
-- A);
-- else
-- System.Tasking.Rendezvous.Requeue_Task_Entry
-- (O._task_id,
-- Task_Entry_Index (I),
-- A);
-- end if;
Append_To (Stmts,
Make_If_Statement (Loc,
Condition => Make_Identifier (Loc, Name_uF),
Then_Statements => New_List (
-- Call to Requeue_Protected_To_Task_Entry
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of
(RTE (RE_Requeue_Protected_To_Task_Entry), Loc),
Parameter_Associations => New_List (
Unchecked_Convert_To ( -- PEA (P)
RTE (RE_Protection_Entries_Access),
Make_Identifier (Loc, Name_uP)),
Make_Selected_Component (Loc, -- O._task_id
Prefix => Make_Identifier (Loc, Name_uO),
Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
Unchecked_Convert_To ( -- entry index
RTE (RE_Task_Entry_Index),
Make_Identifier (Loc, Name_uI)),
Make_Identifier (Loc, Name_uA)))), -- abort status
Else_Statements => New_List (
-- Call to Requeue_Task_Entry
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Requeue_Task_Entry), Loc),
Parameter_Associations => New_List (
Make_Selected_Component (Loc, -- O._task_id
Prefix => Make_Identifier (Loc, Name_uO),
Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
Unchecked_Convert_To ( -- entry index
RTE (RE_Task_Entry_Index),
Make_Identifier (Loc, Name_uI)),
Make_Identifier (Loc, Name_uA)))))); -- abort status
end if;
-- Even though no declarations are needed in both cases, we allocate
-- a list for entities added by Freeze.
return
Make_Subprogram_Body (Loc,
Specification => Make_Disp_Requeue_Spec (Typ),
Declarations => New_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Stmts));
end Make_Disp_Requeue_Body;
----------------------------
-- Make_Disp_Requeue_Spec --
----------------------------
function Make_Disp_Requeue_Spec
(Typ : Entity_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Typ);
begin
pragma Assert (not Restriction_Active (No_Dispatching_Calls));
-- O : in out Typ; - Object parameter
-- F : Boolean; - Protected (True) / task (False) flag
-- P : Address; - Protection_Entries_Access value
-- I : Entry_Index - Index of entry call
-- A : Boolean - Abort flag
-- Note that the Protection_Entries_Access value is represented as a
-- System.Address in order to avoid dragging in the tasking runtime
-- when compiling sources without tasking constructs.
return
Make_Procedure_Specification (Loc,
Defining_Unit_Name =>
Make_Defining_Identifier (Loc, Name_uDisp_Requeue),
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc, -- O
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uO),
Parameter_Type =>
New_Occurrence_Of (Typ, Loc),
In_Present => True,
Out_Present => True),
Make_Parameter_Specification (Loc, -- F
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uF),
Parameter_Type =>
New_Occurrence_Of (Standard_Boolean, Loc)),
Make_Parameter_Specification (Loc, -- P
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uP),
Parameter_Type =>
New_Occurrence_Of (RTE (RE_Address), Loc)),
Make_Parameter_Specification (Loc, -- I
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uI),
Parameter_Type =>
New_Occurrence_Of (Standard_Integer, Loc)),
Make_Parameter_Specification (Loc, -- A
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uA),
Parameter_Type =>
New_Occurrence_Of (Standard_Boolean, Loc))));
end Make_Disp_Requeue_Spec;
---------------------------------
-- Make_Disp_Timed_Select_Body --
---------------------------------
-- For interface types, generate:
-- procedure _Disp_Timed_Select
-- (T : in out <Typ>;
-- S : Integer;
-- P : System.Address;
-- D : Duration;
-- M : Integer;
-- C : out Ada.Tags.Prim_Op_Kind;
-- F : out Boolean)
-- is
-- begin
-- F := False;
-- C := Ada.Tags.POK_Function;
-- end _Disp_Timed_Select;
-- For protected types, generate:
-- procedure _Disp_Timed_Select
-- (T : in out <Typ>;
-- S : Integer;
-- P : System.Address;
-- D : Duration;
-- M : Integer;
-- C : out Ada.Tags.Prim_Op_Kind;
-- F : out Boolean)
-- is
-- I : Integer;
-- begin
-- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag (<Typ>VP), S);
-- if C = Ada.Tags.POK_Procedure
-- or else C = Ada.Tags.POK_Protected_Procedure
-- or else C = Ada.Tags.POK_Task_Procedure
-- then
-- F := True;
-- return;
-- end if;
-- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP), S);
-- System.Tasking.Protected_Objects.Operations.
-- Timed_Protected_Entry_Call
-- (T._object'Access,
-- System.Tasking.Protected_Objects.Protected_Entry_Index (I),
-- P,
-- D,
-- M,
-- F);
-- end _Disp_Timed_Select;
-- For task types, generate:
-- procedure _Disp_Timed_Select
-- (T : in out <Typ>;
-- S : Integer;
-- P : System.Address;
-- D : Duration;
-- M : Integer;
-- C : out Ada.Tags.Prim_Op_Kind;
-- F : out Boolean)
-- is
-- I : Integer;
-- begin
-- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP), S);
-- System.Tasking.Rendezvous.Timed_Task_Entry_Call
-- (T._task_id,
-- System.Tasking.Task_Entry_Index (I),
-- P,
-- D,
-- M,
-- F);
-- end _Disp_Time_Select;
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;
Obj_Ref : Node_Id;
Stmts : constant List_Id := New_List;
Tag_Node : Node_Id;
begin
pragma Assert (not Restriction_Active (No_Dispatching_Calls));
-- Null body is generated for interface types
if Is_Interface (Typ) then
return
Make_Subprogram_Body (Loc,
Specification => Make_Disp_Timed_Select_Spec (Typ),
Declarations => New_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
New_List (
Make_Assignment_Statement (Loc,
Name => Make_Identifier (Loc, Name_uF),
Expression => New_Occurrence_Of (Standard_False, Loc)))));
end if;
if Is_Concurrent_Record_Type (Typ) then
Conc_Typ := Corresponding_Concurrent_Type (Typ);
-- 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_Occurrence_Of (Standard_Integer, Loc)));
-- 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;
Build_Common_Dispatching_Select_Statements (Typ, Stmts);
-- Generate:
-- I := Get_Entry_Index (tag! (<type>VP), S);
-- I is the entry index and S is the dispatch table slot
if Tagged_Type_Expansion then
Tag_Node :=
Unchecked_Convert_To (RTE (RE_Tag),
New_Occurrence_Of
(Node (First_Elmt (Access_Disp_Table (Typ))), Loc));
else
Tag_Node :=
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Typ, Loc),
Attribute_Name => Name_Tag);
end if;
Append_To (Stmts,
Make_Assignment_Statement (Loc,
Name => Make_Identifier (Loc, Name_uI),
Expression =>
Make_Function_Call (Loc,
Name => New_Occurrence_Of (RTE (RE_Get_Entry_Index), Loc),
Parameter_Associations => New_List (
Tag_Node,
Make_Identifier (Loc, Name_uS)))));
-- Protected case
if Ekind (Conc_Typ) = E_Protected_Type then
-- Build T._object'Access
Obj_Ref :=
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Unchecked_Access,
Prefix =>
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_uT),
Selector_Name => Make_Identifier (Loc, Name_uObject)));
-- Normal case, No_Entry_Queue restriction not active. In this
-- case we 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.
-- Historically, there was also an implementation for single
-- entry protected types (in s-tposen). However, it was removed
-- by also testing for no No_Select_Statements restriction in
-- Exp_Utils.Corresponding_Runtime_Package. This simplified the
-- implementation of s-tposen.adb and provided consistency between
-- all versions of System.Tasking.Protected_Objects.Single_Entry
-- (s-tposen*.adb).
case Corresponding_Runtime_Package (Conc_Typ) is
when System_Tasking_Protected_Objects_Entries =>
Append_To (Stmts,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of
(RTE (RE_Timed_Protected_Entry_Call), Loc),
Parameter_Associations => New_List (
Obj_Ref,
Unchecked_Convert_To ( -- entry index
RTE (RE_Protected_Entry_Index),
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
when others =>
raise Program_Error;
end case;
-- Task case
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_Occurrence_Of (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)),
Unchecked_Convert_To ( -- entry index
RTE (RE_Task_Entry_Index),
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;
else
-- Initialize out parameters
Append_To (Stmts,
Make_Assignment_Statement (Loc,
Name => Make_Identifier (Loc, Name_uF),
Expression => New_Occurrence_Of (Standard_False, Loc)));
Append_To (Stmts,
Make_Assignment_Statement (Loc,
Name => Make_Identifier (Loc, Name_uC),
Expression => New_Occurrence_Of (RTE (RE_POK_Function), 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);
Def_Id : constant Node_Id :=
Make_Defining_Identifier (Loc,
Name_uDisp_Timed_Select);
Params : constant List_Id := New_List;
begin
pragma Assert (not Restriction_Active (No_Dispatching_Calls));
-- T : in out Typ; -- Object parameter
-- S : Integer; -- Primitive operation slot
-- P : Address; -- Wrapped parameters
-- D : Duration; -- Delay
-- M : Integer; -- Delay Mode
-- C : out Prim_Op_Kind; -- Call kind
-- F : out Boolean; -- Status flag
Append_List_To (Params, New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_uT),
Parameter_Type => New_Occurrence_Of (Typ, Loc),
In_Present => True,
Out_Present => True),
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_uS),
Parameter_Type => New_Occurrence_Of (Standard_Integer, Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_uP),
Parameter_Type => New_Occurrence_Of (RTE (RE_Address), Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_uD),
Parameter_Type => New_Occurrence_Of (Standard_Duration, Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_uM),
Parameter_Type => New_Occurrence_Of (Standard_Integer, Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_uC),
Parameter_Type =>
New_Occurrence_Of (RTE (RE_Prim_Op_Kind), Loc),
Out_Present => True)));
Append_To (Params,
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_uF),
Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc),
Out_Present => True));
return
Make_Procedure_Specification (Loc,
Defining_Unit_Name => Def_Id,
Parameter_Specifications => Params);
end Make_Disp_Timed_Select_Spec;
-------------
-- Make_DT --
-------------
-- The frontend supports two models for expanding dispatch tables
-- associated with library-level defined tagged types: statically and
-- non-statically allocated dispatch tables. In the former case the object
-- containing the dispatch table is constant and it is initialized by means
-- of a positional aggregate. In the latter case, the object containing
-- the dispatch table is a variable which is initialized by means of
-- assignments.
-- In case of locally defined tagged types, the object containing the
-- object containing the dispatch table is always a variable (instead of a
-- constant). This is currently required to give support to late overriding
-- of primitives. For example:
-- procedure Example is
-- package Pkg is
-- type T1 is tagged null record;
-- procedure Prim (O : T1);
-- end Pkg;
-- type T2 is new Pkg.T1 with null record;
-- procedure Prim (X : T2) is -- late overriding
-- begin
-- ...
-- ...
-- end;
-- WARNING: This routine manages Ghost regions. Return statements must be
-- replaced by gotos which jump to the end of the routine and restore the
-- Ghost mode.
function Make_DT (Typ : Entity_Id; N : Node_Id := Empty) return List_Id is
Loc : constant Source_Ptr := Sloc (Typ);
Max_Predef_Prims : constant Int :=
UI_To_Int
(Intval
(Expression
(Parent (RTE (RE_Max_Predef_Prims)))));
DT_Decl : constant Elist_Id := New_Elmt_List;
DT_Aggr : constant Elist_Id := New_Elmt_List;
-- Entities marked with attribute Is_Dispatch_Table_Entity
Dummy_Object : Entity_Id := Empty;
-- Extra nonexistent object of type Typ internally used to compute the
-- offset to the components that reference secondary dispatch tables.
-- Used to compute the offset of components located at fixed position.
procedure Check_Premature_Freezing
(Subp : Entity_Id;
Tagged_Type : Entity_Id;
Typ : Entity_Id);
-- Verify that all untagged types in the profile of a subprogram are
-- frozen at the point the subprogram is frozen. This enforces the rule
-- on RM 13.14 (14) as modified by AI05-019. At the point a subprogram
-- is frozen, enough must be known about it to build the activation
-- record for it, which requires at least that the size of all
-- parameters be known. Controlling arguments are by-reference,