| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- E X P _ D I S P -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1992-2022, 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 Strub; use Strub; |
| 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); |
| Copy_Strub_Mode (Subp_Typ, Subp); |
| 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 nonconcurrent |
| -- 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, |
| -- and therefore the rule only applies to untagged types. Typical |
| -- violation of the rule involves an object declaration that freezes a |
| -- tagged type, when one of its primitive operations has a type in its |
| -- profile whose full view has not been analyzed yet. More complex cases |
| -- involve composite types that have one private unfrozen subcomponent. |
| -- Move this check to sem??? |
| |
| procedure Export_DT (Typ : Entity_Id; DT : Entity_Id; Index : Nat := 0); |
| -- Export the dispatch table DT of tagged type Typ. Required to generate |
| -- forward references and statically allocate the table. For primary |
| -- dispatch tables Index is 0; for secondary dispatch tables the value |
| -- of index must match the Suffix_Index value assigned to the table by |
| -- Make_Tags when generating its unique external name, and it is used to |
| -- retrieve from the Dispatch_Table_Wrappers list associated with Typ |
| -- the external name generated by Import_DT. |
| |
| procedure Make_Secondary_DT |
| (Typ : Entity_Id; |
| Iface : Entity_Id; |
| Iface_Comp : Node_Id; |
| Suffix_Index : Int; |
| Num_Iface_Prims : Nat; |
| Iface_DT_Ptr : Entity_Id; |
| Predef_Prims_Ptr : Entity_Id; |
| Build_Thunks : Boolean; |
| Result : List_Id); |
| -- Ada 2005 (AI-251): Expand the declarations for a Secondary Dispatch |
| -- Table of Typ associated with Iface. Each abstract interface of Typ |
| -- has two secondary dispatch tables: one containing pointers to thunks |
| -- and another containing pointers to the primitives covering the |
| -- interface primitives. The former secondary table is generated when |
| -- Build_Thunks is True, and provides common support for dispatching |
| -- calls through interface types; the latter secondary table is |
| -- generated when Build_Thunks is False, and provides support for |
| -- Generic Dispatching Constructors that dispatch calls through |
| -- interface types. When constructing this latter table the value of |
| -- Suffix_Index is -1 to indicate that there is no need to export such |
| -- table when building statically allocated dispatch tables; a positive |
| -- value of Suffix_Index must match the Suffix_Index value assigned to |
| -- this secondary dispatch table by Make_Tags when its unique external |
| -- name was generated. |
| |
| function Number_Of_Predefined_Prims (Typ : Entity_Id) return Nat; |
| -- Returns the number of predefined primitives of Typ |
| |
| ------------------------------ |
| -- Check_Premature_Freezing -- |
| ------------------------------ |
| |
| procedure Check_Premature_Freezing |
| (Subp : Entity_Id; |
| Tagged_Type : Entity_Id; |
| Typ : Entity_Id) |
| is |
| Comp : Entity_Id; |
| |
| function Is_Actual_For_Formal_Incomplete_Type |
| (T : Entity_Id) return Boolean; |
| -- In Ada 2012, if a nested generic has an incomplete formal type, |
| -- the actual may be (and usually is) a private type whose completion |
| -- appears later. It is safe to build the dispatch table in this |
| -- case, gigi will have full views available. |
| |
| ------------------------------------------ |
| -- Is_Actual_For_Formal_Incomplete_Type -- |
| ------------------------------------------ |
| |
| function Is_Actual_For_Formal_Incomplete_Type |
| (T : Entity_Id) return Boolean |
| is |
| Gen_Par : Entity_Id; |
| F : Node_Id; |
| |
| begin |
| if not Is_Generic_Instance (Current_Scope) |
| or else not Used_As_Generic_Actual (T) |
| then |
| return False; |
| else |
| Gen_Par := Generic_Parent (Parent (Current_Scope)); |
| end if; |
| |
| F := |
| First |
| (Generic_Formal_Declarations |
| (Unit_Declaration_Node (Gen_Par))); |
| while Present (F) loop |
| if Ekind (Defining_Identifier (F)) = E_Incomplete_Type then |
| return True; |
| end if; |
| |
| Next (F); |
| end loop; |
| |
| return False; |
| end Is_Actual_For_Formal_Incomplete_Type; |
| |
| -- Start of processing for Check_Premature_Freezing |
| |
| begin |
| -- Note that if the type is a (subtype of) a generic actual, the |
| -- actual will have been frozen by the instantiation. |
| |
| if Present (N) |
| and then Is_Private_Type (Typ) |
| and then No (Full_View (Typ)) |
| and then not Has_Private_Declaration (Typ) |
| and then not Is_Generic_Type (Typ) |
| and then not Is_Tagged_Type (Typ) |
| and then not Is_Frozen (Typ) |
| and then not Is_Generic_Actual_Type (Typ) |
| then |
| Error_Msg_Sloc := Sloc (Subp); |
| Error_Msg_NE |
| ("declaration must appear after completion of type &", N, Typ); |
| Error_Msg_NE |
| ("\which is an untagged type in the profile of " |
| & "primitive operation & declared#", N, Subp); |
| |
| else |
| Comp := Private_Component (Typ); |
| |
| if not Is_Tagged_Type (Typ) |
| and then Present (Comp) |
| and then not Is_Frozen (Comp) |
| and then not Has_Private_Declaration (Comp) |
| and then not Is_Actual_For_Formal_Incomplete_Type (Comp) |
| then |
| Error_Msg_Sloc := Sloc (Subp); |
| Error_Msg_Node_2 := Subp; |
| Error_Msg_Name_1 := Chars (Tagged_Type); |
| Error_Msg_NE |
| ("declaration must appear after completion of type &", |
| N, Comp); |
| Error_Msg_NE |
| ("\which is a component of untagged type& in the profile " |
| & "of primitive & of type % that is frozen by the " |
| & "declaration", N, Typ); |
| end if; |
| end if; |
| end Check_Premature_Freezing; |
| |
| --------------- |
| -- Export_DT -- |
| --------------- |
| |
| procedure Export_DT (Typ : Entity_Id; DT : Entity_Id; Index : Nat := 0) |
| is |
| Count : Nat; |
| Elmt : Elmt_Id; |
| |
| begin |
| Set_Is_Statically_Allocated (DT); |
| Set_Is_True_Constant (DT); |
| Set_Is_Exported (DT); |
| |
| Count := 0; |
| Elmt := First_Elmt (Dispatch_Table_Wrappers (Typ)); |
| while Count /= Index loop |
| Next_Elmt (Elmt); |
| Count := Count + 1; |
| end loop; |
| |
| -- Related_Type (Node (Elmt)) should be equal to Typ here, but we |
| -- can't assert that, because it is sometimes false in illegal |
| -- programs. We can't check Serious_Errors_Detected, because the |
| -- errors have not yet been detected. |
| |
| Get_External_Name (Node (Elmt)); |
| Set_Interface_Name (DT, |
| Make_String_Literal (Loc, |
| Strval => String_From_Name_Buffer)); |
| |
| -- Ensure proper Sprint output of this implicit importation |
| |
| Set_Is_Internal (DT); |
| Set_Is_Public (DT); |
| end Export_DT; |
| |
| ----------------------- |
| -- Make_Secondary_DT -- |
| ----------------------- |
| |
| procedure Make_Secondary_DT |
| (Typ : Entity_Id; |
| Iface : Entity_Id; |
| Iface_Comp : Node_Id; |
| Suffix_Index : Int; |
| Num_Iface_Prims : Nat; |
| Iface_DT_Ptr : Entity_Id; |
| Predef_Prims_Ptr : Entity_Id; |
| Build_Thunks : Boolean; |
| Result : List_Id) |
| is |
| Loc : constant Source_Ptr := Sloc (Typ); |
| Exporting_Table : constant Boolean := |
| Building_Static_DT (Typ) |
| and then Suffix_Index > 0; |
| Iface_DT : constant Entity_Id := Make_Temporary (Loc, 'T'); |
| Predef_Prims : constant Entity_Id := Make_Temporary (Loc, 'R'); |
| DT_Constr_List : List_Id; |
| DT_Aggr_List : List_Id; |
| Empty_DT : Boolean := False; |
| Nb_Prim : Nat; |
| New_Node : Node_Id; |
| OSD : Entity_Id; |
| OSD_Aggr_List : List_Id; |
| Prim : Entity_Id; |
| Prim_Elmt : Elmt_Id; |
| Prim_Ops_Aggr_List : List_Id; |
| |
| begin |
| -- Handle cases in which we do not generate statically allocated |
| -- dispatch tables. |
| |
| if not Building_Static_DT (Typ) then |
| Mutate_Ekind (Predef_Prims, E_Variable); |
| Mutate_Ekind (Iface_DT, E_Variable); |
| |
| -- Statically allocated dispatch tables and related entities are |
| -- constants. |
| |
| else |
| Mutate_Ekind (Predef_Prims, E_Constant); |
| Set_Is_Statically_Allocated (Predef_Prims); |
| Set_Is_True_Constant (Predef_Prims); |
| |
| Mutate_Ekind (Iface_DT, E_Constant); |
| Set_Is_Statically_Allocated (Iface_DT); |
| Set_Is_True_Constant (Iface_DT); |
| end if; |
| |
| -- Calculate the number of slots of the dispatch table. If the number |
| -- of primitives of Typ is 0 we reserve a dummy single entry for its |
| -- DT because at run time the pointer to this dummy entry will be |
| -- used as the tag. |
| |
| if Num_Iface_Prims = 0 then |
| Empty_DT := True; |
| Nb_Prim := 1; |
| else |
| Nb_Prim := Num_Iface_Prims; |
| end if; |
| |
| -- Generate: |
| |
| -- Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) := |
| -- (predef-prim-op-thunk-1'address, |
| -- predef-prim-op-thunk-2'address, |
| -- ... |
| -- predef-prim-op-thunk-n'address); |
| |
| -- Create the thunks associated with the predefined primitives and |
| -- save their entity to fill the aggregate. |
| |
| declare |
| Nb_P_Prims : constant Nat := Number_Of_Predefined_Prims (Typ); |
| Prim_Table : array (Nat range 1 .. Nb_P_Prims) of Entity_Id; |
| Decl : Node_Id; |
| Thunk_Id : Entity_Id; |
| Thunk_Code : Node_Id; |
| |
| begin |
| Prim_Ops_Aggr_List := New_List; |
| Prim_Table := (others => Empty); |
| |
| if Building_Static_DT (Typ) then |
| Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); |
| while Present (Prim_Elmt) loop |
| Prim := Node (Prim_Elmt); |
| |
| if Is_Predefined_Dispatching_Operation (Prim) |
| and then not Is_Abstract_Subprogram (Prim) |
| and then not Is_Eliminated (Prim) |
| and then not Generate_SCIL |
| and then not Present (Prim_Table |
| (UI_To_Int (DT_Position (Prim)))) |
| then |
| if not Build_Thunks then |
| Prim_Table (UI_To_Int (DT_Position (Prim))) := |
| Alias (Prim); |
| |
| else |
| Expand_Interface_Thunk |
| (Prim, Thunk_Id, Thunk_Code, Iface); |
| |
| if Present (Thunk_Id) then |
| Append_To (Result, Thunk_Code); |
| Prim_Table (UI_To_Int (DT_Position (Prim))) := |
| Thunk_Id; |
| end if; |
| end if; |
| end if; |
| |
| Next_Elmt (Prim_Elmt); |
| end loop; |
| end if; |
| |
| for J in Prim_Table'Range loop |
| if Present (Prim_Table (J)) then |
| New_Node := |
| Unchecked_Convert_To (RTE (RE_Prim_Ptr), |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Prim_Table (J), Loc), |
| Attribute_Name => Name_Unrestricted_Access)); |
| else |
| New_Node := Make_Null (Loc); |
| end if; |
| |
| Append_To (Prim_Ops_Aggr_List, New_Node); |
| end loop; |
| |
| New_Node := |
| Make_Aggregate (Loc, Expressions => Prim_Ops_Aggr_List); |
| |
| -- Remember aggregates initializing dispatch tables |
| |
| Append_Elmt (New_Node, DT_Aggr); |
| |
| Decl := |
| Make_Subtype_Declaration (Loc, |
| Defining_Identifier => Make_Temporary (Loc, 'S'), |
| Subtype_Indication => |
| New_Occurrence_Of (RTE (RE_Address_Array), Loc)); |
| |
| Append_To (Result, Decl); |
| |
| Append_To (Result, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Predef_Prims, |
| Constant_Present => Building_Static_DT (Typ), |
| Aliased_Present => True, |
| Object_Definition => New_Occurrence_Of |
| (Defining_Identifier (Decl), Loc), |
| Expression => New_Node)); |
| end; |
| |
| -- Generate |
| |
| -- OSD : Ada.Tags.Object_Specific_Data (Nb_Prims) := |
| -- (OSD_Table => (1 => <value>, |
| -- ... |
| -- N => <value>)); |
| -- for OSD'Alignment use Address'Alignment; |
| |
| -- Iface_DT : Dispatch_Table (Nb_Prims) := |
| -- ([ Signature => <sig-value> ], |
| -- Tag_Kind => <tag_kind-value>, |
| -- Predef_Prims => Predef_Prims'Address, |
| -- Offset_To_Top => 0, |
| -- OSD => OSD'Address, |
| -- Prims_Ptr => (prim-op-1'address, |
| -- prim-op-2'address, |
| -- ... |
| -- prim-op-n'address)); |
| |
| -- Stage 3: Initialize the discriminant and the record components |
| |
| DT_Constr_List := New_List; |
| DT_Aggr_List := New_List; |
| |
| -- Nb_Prim |
| |
| Append_To (DT_Constr_List, Make_Integer_Literal (Loc, Nb_Prim)); |
| Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, Nb_Prim)); |
| |
| -- Signature |
| |
| if RTE_Record_Component_Available (RE_Signature) then |
| Append_To (DT_Aggr_List, |
| New_Occurrence_Of (RTE (RE_Secondary_DT), Loc)); |
| end if; |
| |
| -- Tag_Kind |
| |
| if RTE_Record_Component_Available (RE_Tag_Kind) then |
| Append_To (DT_Aggr_List, Tagged_Kind (Typ)); |
| end if; |
| |
| -- Predef_Prims |
| |
| Append_To (DT_Aggr_List, |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Predef_Prims, Loc), |
| Attribute_Name => Name_Address)); |
| |
| -- Interface component located at variable offset; the value of |
| -- Offset_To_Top will be set by the init subprogram. |
| |
| if No (Dummy_Object) |
| or else Is_Variable_Size_Record (Etype (Scope (Iface_Comp))) |
| then |
| Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0)); |
| |
| -- Interface component located at fixed offset |
| |
| else |
| Append_To (DT_Aggr_List, |
| Make_Op_Minus (Loc, |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| Make_Selected_Component (Loc, |
| Prefix => |
| New_Occurrence_Of (Dummy_Object, Loc), |
| Selector_Name => |
| New_Occurrence_Of (Iface_Comp, Loc)), |
| Attribute_Name => Name_Position))); |
| end if; |
| |
| -- Generate the Object Specific Data table required to dispatch calls |
| -- through synchronized interfaces. |
| |
| if Empty_DT |
| or else Is_Abstract_Type (Typ) |
| or else Is_Controlled (Typ) |
| or else Restriction_Active (No_Dispatching_Calls) |
| or else not Is_Limited_Type (Typ) |
| or else not Has_Interfaces (Typ) |
| or else not Build_Thunks |
| or else not RTE_Record_Component_Available (RE_OSD_Table) |
| then |
| -- No OSD table required |
| |
| Append_To (DT_Aggr_List, |
| New_Occurrence_Of (RTE (RE_Null_Address), Loc)); |
| |
| else |
| OSD_Aggr_List := New_List; |
| |
| declare |
| Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id; |
| Prim : Entity_Id; |
| Prim_Alias : Entity_Id; |
| Prim_Elmt : Elmt_Id; |
| E : Entity_Id; |
| Count : Nat := 0; |
| Pos : Nat; |
| |
| begin |
| Prim_Table := (others => Empty); |
| Prim_Alias := Empty; |
| |
| Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); |
| while Present (Prim_Elmt) loop |
| Prim := Node (Prim_Elmt); |
| |
| if Present (Interface_Alias (Prim)) |
| and then Find_Dispatching_Type |
| (Interface_Alias (Prim)) = Iface |
| then |
| Prim_Alias := Interface_Alias (Prim); |
| E := Ultimate_Alias (Prim); |
| Pos := UI_To_Int (DT_Position (Prim_Alias)); |
| |
| if Present (Prim_Table (Pos)) then |
| pragma Assert (Prim_Table (Pos) = E); |
| null; |
| |
| else |
| Prim_Table (Pos) := E; |
| |
| Append_To (OSD_Aggr_List, |
| Make_Component_Association (Loc, |
| Choices => New_List ( |
| Make_Integer_Literal (Loc, |
| DT_Position (Prim_Alias))), |
| Expression => |
| Make_Integer_Literal (Loc, |
| DT_Position (Alias (Prim))))); |
| |
| Count := Count + 1; |
| end if; |
| end if; |
| |
| Next_Elmt (Prim_Elmt); |
| end loop; |
| pragma Assert (Count = Nb_Prim); |
| end; |
| |
| OSD := Make_Temporary (Loc, 'I'); |
| |
| Append_To (Result, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => OSD, |
| Constant_Present => True, |
| Object_Definition => |
| Make_Subtype_Indication (Loc, |
| Subtype_Mark => |
| New_Occurrence_Of (RTE (RE_Object_Specific_Data), Loc), |
| Constraint => |
| Make_Index_Or_Discriminant_Constraint (Loc, |
| Constraints => New_List ( |
| Make_Integer_Literal (Loc, Nb_Prim)))), |
| |
| Expression => |
| Make_Aggregate (Loc, |
| Component_Associations => New_List ( |
| Make_Component_Association (Loc, |
| Choices => New_List ( |
| New_Occurrence_Of |
| (RTE_Record_Component (RE_OSD_Num_Prims), Loc)), |
| Expression => |
| Make_Integer_Literal (Loc, Nb_Prim)), |
| |
| Make_Component_Association (Loc, |
| Choices => New_List ( |
| New_Occurrence_Of |
| (RTE_Record_Component (RE_OSD_Table), Loc)), |
| Expression => Make_Aggregate (Loc, |
| Component_Associations => OSD_Aggr_List)))))); |
| |
| Append_To (Result, |
| Make_Attribute_Definition_Clause (Loc, |
| Name => New_Occurrence_Of (OSD, Loc), |
| Chars => Name_Alignment, |
| Expression => |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of (RTE (RE_Integer_Address), Loc), |
| Attribute_Name => Name_Alignment))); |
| |
| -- In secondary dispatch tables the Typeinfo component contains |
| -- the address of the Object Specific Data (see a-tags.ads). |
| |
| Append_To (DT_Aggr_List, |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (OSD, Loc), |
| Attribute_Name => Name_Address)); |
| end if; |
| |
| -- Initialize the table of primitive operations |
| |
| Prim_Ops_Aggr_List := New_List; |
| |
| if Empty_DT then |
| Append_To (Prim_Ops_Aggr_List, Make_Null (Loc)); |
| |
| elsif Is_Abstract_Type (Typ) |
| or else not Building_Static_DT (Typ) |
| then |
| for J in 1 .. Nb_Prim loop |
| Append_To (Prim_Ops_Aggr_List, Make_Null (Loc)); |
| end loop; |
| |
| else |
| declare |
| CPP_Nb_Prims : constant Nat := CPP_Num_Prims (Typ); |
| E : Entity_Id; |
| Prim_Pos : Nat; |
| Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id; |
| Thunk_Code : Node_Id; |
| Thunk_Id : Entity_Id; |
| |
| begin |
| Prim_Table := (others => Empty); |
| |
| Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); |
| while Present (Prim_Elmt) loop |
| Prim := Node (Prim_Elmt); |
| E := Ultimate_Alias (Prim); |
| Prim_Pos := UI_To_Int (DT_Position (E)); |
| |
| -- Do not reference predefined primitives because they are |
| -- located in a separate dispatch table; skip abstract and |
| -- eliminated primitives; skip primitives located in the C++ |
| -- part of the dispatch table because their slot is set by |
| -- the IC routine. |
| |
| if not Is_Predefined_Dispatching_Operation (Prim) |
| and then Present (Interface_Alias (Prim)) |
| and then not Is_Abstract_Subprogram (Alias (Prim)) |
| and then not Is_Eliminated (Alias (Prim)) |
| |
