| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- E X P _ D I S P -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- |
| -- -- |
| -- GNAT is free software; you can redistribute it and/or modify it under -- |
| -- terms of the GNU General Public License as published by the Free Soft- -- |
| -- ware Foundation; either version 2, or (at your option) any later ver- -- |
| -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- |
| -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- |
| -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- |
| -- for more details. You should have received a copy of the GNU General -- |
| -- Public License distributed with GNAT; see file COPYING. If not, write -- |
| -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- |
| -- Boston, MA 02110-1301, USA. -- |
| -- -- |
| -- GNAT was originally developed by the GNAT team at New York University. -- |
| -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| |
| with Atree; use Atree; |
| with Checks; use Checks; |
| with Debug; use Debug; |
| with Einfo; use Einfo; |
| with Elists; use Elists; |
| with Errout; use Errout; |
| with Exp_Ch7; use Exp_Ch7; |
| with Exp_Dbug; use Exp_Dbug; |
| with Exp_Tss; use Exp_Tss; |
| with Exp_Util; use Exp_Util; |
| with Itypes; use Itypes; |
| 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_Disp; use Sem_Disp; |
| with Sem_Res; use Sem_Res; |
| with Sem_Type; use Sem_Type; |
| with Sem_Util; use Sem_Util; |
| with Sinfo; use Sinfo; |
| with Snames; use Snames; |
| with Stand; use Stand; |
| with Tbuild; use Tbuild; |
| with Uintp; use Uintp; |
| |
| package body Exp_Disp is |
| |
| -------------------------------- |
| -- Select_Expansion_Utilities -- |
| -------------------------------- |
| |
| -- The following package contains helper routines used in the expansion of |
| -- dispatching asynchronous, conditional and timed selects. |
| |
| package Select_Expansion_Utilities is |
| procedure Build_B |
| (Loc : Source_Ptr; |
| Params : List_Id); |
| -- Generate: |
| -- B : out Communication_Block |
| |
| procedure Build_C |
| (Loc : Source_Ptr; |
| Params : List_Id); |
| -- Generate: |
| -- C : out Prim_Op_Kind |
| |
| procedure Build_Common_Dispatching_Select_Statements |
| (Loc : Source_Ptr; |
| Typ : Entity_Id; |
| DT_Ptr : Entity_Id; |
| Stmts : List_Id); |
| -- Ada 2005 (AI-345): Generate statements that are common between |
| -- asynchronous, conditional and timed select expansion. |
| |
| procedure Build_F |
| (Loc : Source_Ptr; |
| Params : List_Id); |
| -- Generate: |
| -- F : out Boolean |
| |
| procedure Build_P |
| (Loc : Source_Ptr; |
| Params : List_Id); |
| -- Generate: |
| -- P : Address |
| |
| procedure Build_S |
| (Loc : Source_Ptr; |
| Params : List_Id); |
| -- Generate: |
| -- S : Integer |
| |
| procedure Build_T |
| (Loc : Source_Ptr; |
| Typ : Entity_Id; |
| Params : List_Id); |
| -- Generate: |
| -- T : in out Typ |
| end Select_Expansion_Utilities; |
| |
| package body Select_Expansion_Utilities is |
| |
| ------------- |
| -- Build_B -- |
| ------------- |
| |
| procedure Build_B |
| (Loc : Source_Ptr; |
| Params : List_Id) |
| is |
| begin |
| Append_To (Params, |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uB), |
| Parameter_Type => |
| New_Reference_To (RTE (RE_Communication_Block), Loc), |
| Out_Present => True)); |
| end Build_B; |
| |
| ------------- |
| -- Build_C -- |
| ------------- |
| |
| procedure Build_C |
| (Loc : Source_Ptr; |
| Params : List_Id) |
| is |
| begin |
| Append_To (Params, |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uC), |
| Parameter_Type => |
| New_Reference_To (RTE (RE_Prim_Op_Kind), Loc), |
| Out_Present => True)); |
| end Build_C; |
| |
| ------------------------------------------------ |
| -- Build_Common_Dispatching_Select_Statements -- |
| ------------------------------------------------ |
| |
| procedure Build_Common_Dispatching_Select_Statements |
| (Loc : Source_Ptr; |
| Typ : Entity_Id; |
| DT_Ptr : Entity_Id; |
| Stmts : List_Id) |
| is |
| begin |
| -- Generate: |
| -- C := get_prim_op_kind (tag! (<type>VP), S); |
| |
| -- where C is the out parameter capturing the call kind and S is the |
| -- dispatch table slot number. |
| |
| Append_To (Stmts, |
| Make_Assignment_Statement (Loc, |
| Name => |
| Make_Identifier (Loc, Name_uC), |
| Expression => |
| Make_DT_Access_Action (Typ, |
| Action => |
| Get_Prim_Op_Kind, |
| Args => |
| New_List ( |
| Unchecked_Convert_To (RTE (RE_Tag), |
| New_Reference_To (DT_Ptr, Loc)), |
| Make_Identifier (Loc, Name_uS))))); |
| |
| -- Generate: |
| |
| -- if C = POK_Procedure |
| -- or else C = POK_Protected_Procedure |
| -- or else C = POK_Task_Procedure; |
| -- then |
| -- F := True; |
| -- return; |
| |
| -- where F is the out parameter capturing the status of a potential |
| -- entry call. |
| |
| Append_To (Stmts, |
| Make_If_Statement (Loc, |
| |
| Condition => |
| Make_Or_Else (Loc, |
| Left_Opnd => |
| Make_Op_Eq (Loc, |
| Left_Opnd => |
| Make_Identifier (Loc, Name_uC), |
| Right_Opnd => |
| New_Reference_To (RTE (RE_POK_Procedure), Loc)), |
| Right_Opnd => |
| Make_Or_Else (Loc, |
| Left_Opnd => |
| Make_Op_Eq (Loc, |
| Left_Opnd => |
| Make_Identifier (Loc, Name_uC), |
| Right_Opnd => |
| New_Reference_To (RTE ( |
| RE_POK_Protected_Procedure), Loc)), |
| Right_Opnd => |
| Make_Op_Eq (Loc, |
| Left_Opnd => |
| Make_Identifier (Loc, Name_uC), |
| Right_Opnd => |
| New_Reference_To (RTE ( |
| RE_POK_Task_Procedure), Loc)))), |
| |
| Then_Statements => |
| New_List ( |
| Make_Assignment_Statement (Loc, |
| Name => Make_Identifier (Loc, Name_uF), |
| Expression => New_Reference_To (Standard_True, Loc)), |
| |
| Make_Return_Statement (Loc)))); |
| end Build_Common_Dispatching_Select_Statements; |
| |
| ------------- |
| -- Build_F -- |
| ------------- |
| |
| procedure Build_F |
| (Loc : Source_Ptr; |
| Params : List_Id) |
| is |
| begin |
| Append_To (Params, |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uF), |
| Parameter_Type => |
| New_Reference_To (Standard_Boolean, Loc), |
| Out_Present => True)); |
| end Build_F; |
| |
| ------------- |
| -- Build_P -- |
| ------------- |
| |
| procedure Build_P |
| (Loc : Source_Ptr; |
| Params : List_Id) |
| is |
| begin |
| Append_To (Params, |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uP), |
| Parameter_Type => |
| New_Reference_To (RTE (RE_Address), Loc))); |
| end Build_P; |
| |
| ------------- |
| -- Build_S -- |
| ------------- |
| |
| procedure Build_S |
| (Loc : Source_Ptr; |
| Params : List_Id) |
| is |
| begin |
| Append_To (Params, |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uS), |
| Parameter_Type => |
| New_Reference_To (Standard_Integer, Loc))); |
| end Build_S; |
| |
| ------------- |
| -- Build_T -- |
| ------------- |
| |
| procedure Build_T |
| (Loc : Source_Ptr; |
| Typ : Entity_Id; |
| Params : List_Id) |
| is |
| begin |
| Append_To (Params, |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uT), |
| Parameter_Type => |
| New_Reference_To (Typ, Loc), |
| In_Present => True, |
| Out_Present => True)); |
| end Build_T; |
| end Select_Expansion_Utilities; |
| |
| package SEU renames Select_Expansion_Utilities; |
| |
| Ada_Actions : constant array (DT_Access_Action) of RE_Id := |
| (CW_Membership => RE_CW_Membership, |
| IW_Membership => RE_IW_Membership, |
| DT_Entry_Size => RE_DT_Entry_Size, |
| DT_Prologue_Size => RE_DT_Prologue_Size, |
| Get_Access_Level => RE_Get_Access_Level, |
| Get_Entry_Index => RE_Get_Entry_Index, |
| Get_External_Tag => RE_Get_External_Tag, |
| Get_Predefined_Prim_Op_Address => RE_Get_Predefined_Prim_Op_Address, |
| Get_Prim_Op_Address => RE_Get_Prim_Op_Address, |
| Get_Prim_Op_Kind => RE_Get_Prim_Op_Kind, |
| Get_RC_Offset => RE_Get_RC_Offset, |
| Get_Remotely_Callable => RE_Get_Remotely_Callable, |
| Get_Tagged_Kind => RE_Get_Tagged_Kind, |
| Inherit_DT => RE_Inherit_DT, |
| Inherit_TSD => RE_Inherit_TSD, |
| Register_Interface_Tag => RE_Register_Interface_Tag, |
| Register_Tag => RE_Register_Tag, |
| Set_Access_Level => RE_Set_Access_Level, |
| Set_Entry_Index => RE_Set_Entry_Index, |
| Set_Expanded_Name => RE_Set_Expanded_Name, |
| Set_External_Tag => RE_Set_External_Tag, |
| Set_Interface_Table => RE_Set_Interface_Table, |
| Set_Offset_Index => RE_Set_Offset_Index, |
| Set_OSD => RE_Set_OSD, |
| Set_Predefined_Prim_Op_Address => RE_Set_Predefined_Prim_Op_Address, |
| Set_Prim_Op_Address => RE_Set_Prim_Op_Address, |
| Set_Prim_Op_Kind => RE_Set_Prim_Op_Kind, |
| Set_RC_Offset => RE_Set_RC_Offset, |
| Set_Remotely_Callable => RE_Set_Remotely_Callable, |
| Set_Signature => RE_Set_Signature, |
| Set_SSD => RE_Set_SSD, |
| Set_TSD => RE_Set_TSD, |
| Set_Tagged_Kind => RE_Set_Tagged_Kind, |
| TSD_Entry_Size => RE_TSD_Entry_Size, |
| TSD_Prologue_Size => RE_TSD_Prologue_Size); |
| |
| Action_Is_Proc : constant array (DT_Access_Action) of Boolean := |
| (CW_Membership => False, |
| IW_Membership => False, |
| DT_Entry_Size => False, |
| DT_Prologue_Size => False, |
| Get_Access_Level => False, |
| Get_Entry_Index => False, |
| Get_External_Tag => False, |
| Get_Predefined_Prim_Op_Address => False, |
| Get_Prim_Op_Address => False, |
| Get_Prim_Op_Kind => False, |
| Get_RC_Offset => False, |
| Get_Remotely_Callable => False, |
| Get_Tagged_Kind => False, |
| Inherit_DT => True, |
| Inherit_TSD => True, |
| Register_Interface_Tag => True, |
| Register_Tag => True, |
| Set_Access_Level => True, |
| Set_Entry_Index => True, |
| Set_Expanded_Name => True, |
| Set_External_Tag => True, |
| Set_Interface_Table => True, |
| Set_Offset_Index => True, |
| Set_OSD => True, |
| Set_Predefined_Prim_Op_Address => True, |
| Set_Prim_Op_Address => True, |
| Set_Prim_Op_Kind => True, |
| Set_RC_Offset => True, |
| Set_Remotely_Callable => True, |
| Set_Signature => True, |
| Set_SSD => True, |
| Set_TSD => True, |
| Set_Tagged_Kind => True, |
| TSD_Entry_Size => False, |
| TSD_Prologue_Size => False); |
| |
| Action_Nb_Arg : constant array (DT_Access_Action) of Int := |
| (CW_Membership => 2, |
| IW_Membership => 2, |
| DT_Entry_Size => 0, |
| DT_Prologue_Size => 0, |
| Get_Access_Level => 1, |
| Get_Entry_Index => 2, |
| Get_External_Tag => 1, |
| Get_Predefined_Prim_Op_Address => 2, |
| Get_Prim_Op_Address => 2, |
| Get_Prim_Op_Kind => 2, |
| Get_RC_Offset => 1, |
| Get_Remotely_Callable => 1, |
| Get_Tagged_Kind => 1, |
| Inherit_DT => 3, |
| Inherit_TSD => 2, |
| Register_Interface_Tag => 3, |
| Register_Tag => 1, |
| Set_Access_Level => 2, |
| Set_Entry_Index => 3, |
| Set_Expanded_Name => 2, |
| Set_External_Tag => 2, |
| Set_Interface_Table => 2, |
| Set_Offset_Index => 3, |
| Set_OSD => 2, |
| Set_Predefined_Prim_Op_Address => 3, |
| Set_Prim_Op_Address => 3, |
| Set_Prim_Op_Kind => 3, |
| Set_RC_Offset => 2, |
| Set_Remotely_Callable => 2, |
| Set_Signature => 2, |
| Set_SSD => 2, |
| Set_TSD => 2, |
| Set_Tagged_Kind => 2, |
| TSD_Entry_Size => 0, |
| TSD_Prologue_Size => 0); |
| |
| procedure Collect_All_Interfaces (T : Entity_Id); |
| -- Ada 2005 (AI-251): Collect the whole list of interfaces that are |
| -- directly or indirectly implemented by T. Used to compute the size |
| -- of the table of interfaces. |
| |
| 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 Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean; |
| -- Check if the type has a private view or if the public view appears |
| -- in the visible part of a package spec. |
| |
| 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. |
| |
| ---------------------------- |
| -- Collect_All_Interfaces -- |
| ---------------------------- |
| |
| procedure Collect_All_Interfaces (T : Entity_Id) is |
| |
| procedure Add_Interface (Iface : Entity_Id); |
| -- Add the interface it if is not already in the list |
| |
| procedure Collect (Typ : Entity_Id); |
| -- Subsidiary subprogram used to traverse the whole list |
| -- of directly and indirectly implemented interfaces |
| |
| ------------------- |
| -- Add_Interface -- |
| ------------------- |
| |
| procedure Add_Interface (Iface : Entity_Id) is |
| Elmt : Elmt_Id; |
| |
| begin |
| Elmt := First_Elmt (Abstract_Interfaces (T)); |
| while Present (Elmt) and then Node (Elmt) /= Iface loop |
| Next_Elmt (Elmt); |
| end loop; |
| |
| if No (Elmt) then |
| Append_Elmt (Iface, Abstract_Interfaces (T)); |
| end if; |
| end Add_Interface; |
| |
| ------------- |
| -- Collect -- |
| ------------- |
| |
| procedure Collect (Typ : Entity_Id) is |
| Ancestor : Entity_Id; |
| Id : Node_Id; |
| Iface : Entity_Id; |
| Nod : Node_Id; |
| |
| begin |
| if Ekind (Typ) = E_Record_Type_With_Private then |
| Nod := Type_Definition (Parent (Full_View (Typ))); |
| else |
| Nod := Type_Definition (Parent (Typ)); |
| end if; |
| |
| pragma Assert (False |
| or else Nkind (Nod) = N_Derived_Type_Definition |
| or else Nkind (Nod) = N_Record_Definition); |
| |
| -- Include the ancestor if we are generating the whole list |
| -- of interfaces. This is used to know the size of the table |
| -- that stores the tag of all the ancestor interfaces. |
| |
| Ancestor := Etype (Typ); |
| |
| if Ancestor /= Typ then |
| Collect (Ancestor); |
| end if; |
| |
| if Is_Interface (Ancestor) then |
| Add_Interface (Ancestor); |
| end if; |
| |
| -- Traverse the graph of ancestor interfaces |
| |
| if Is_Non_Empty_List (Interface_List (Nod)) then |
| Id := First (Interface_List (Nod)); |
| while Present (Id) loop |
| Iface := Etype (Id); |
| |
| if Is_Interface (Iface) then |
| Add_Interface (Iface); |
| Collect (Iface); |
| end if; |
| |
| Next (Id); |
| end loop; |
| end if; |
| end Collect; |
| |
| -- Start of processing for Collect_All_Interfaces |
| |
| begin |
| Collect (T); |
| end Collect_All_Interfaces; |
| |
| ------------------------------ |
| -- 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 Chars (E) = Name_uAlignment then |
| return Uint_2; |
| |
| elsif TSS_Name = TSS_Stream_Read then |
| return Uint_3; |
| |
| elsif TSS_Name = TSS_Stream_Write then |
| return Uint_4; |
| |
| elsif TSS_Name = TSS_Stream_Input then |
| return Uint_5; |
| |
| elsif TSS_Name = TSS_Stream_Output then |
| return Uint_6; |
| |
| elsif Chars (E) = Name_Op_Eq then |
| return Uint_7; |
| |
| elsif Chars (E) = Name_uAssign then |
| return Uint_8; |
| |
| elsif TSS_Name = TSS_Deep_Adjust then |
| return Uint_9; |
| |
| elsif TSS_Name = TSS_Deep_Finalize then |
| return Uint_10; |
| |
| elsif Ada_Version >= Ada_05 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_Timed_Select then |
| return Uint_15; |
| end if; |
| end if; |
| |
| raise Program_Error; |
| end Default_Prim_Op_Position; |
| |
| ----------------------------- |
| -- 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); |
| Param_List : constant List_Id := Parameter_Associations (Call_Node); |
| Subp : Entity_Id := Entity (Name (Call_Node)); |
| |
| 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. |
| |
| function Controlling_Type (Subp : Entity_Id) return Entity_Id; |
| -- Returns the tagged type for which Subp is a primitive subprogram |
| |
| --------------- |
| -- 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), Res); |
| else |
| return Res; |
| end if; |
| end New_Value; |
| |
| ---------------------- |
| -- Controlling_Type -- |
| ---------------------- |
| |
| function Controlling_Type (Subp : Entity_Id) return Entity_Id is |
| begin |
| if Ekind (Subp) = E_Function |
| and then Has_Controlling_Result (Subp) |
| then |
| return Base_Type (Etype (Subp)); |
| |
| else |
| declare |
| Formal : Entity_Id; |
| |
| begin |
| Formal := First_Formal (Subp); |
| while Present (Formal) loop |
| if Is_Controlling_Formal (Formal) then |
| if Is_Access_Type (Etype (Formal)) then |
| return Base_Type (Designated_Type (Etype (Formal))); |
| else |
| return Base_Type (Etype (Formal)); |
| end if; |
| end if; |
| |
| Next_Formal (Formal); |
| end loop; |
| end; |
| end if; |
| |
| -- Controlling type not found (should never happen) |
| |
| return Empty; |
| end Controlling_Type; |
| |
| -- Start of processing for Expand_Dispatching_Call |
| |
| begin |
| Check_Restriction (No_Dispatching_Calls, Call_Node); |
| |
| -- If this is an inherited operation that was overridden, the body |
| -- that is being called is its alias. |
| |
| if Present (Alias (Subp)) |
| and then Is_Inherited_Operation (Subp) |
| and then No (DTC_Entity (Subp)) |
| then |
| Subp := Alias (Subp); |
| end if; |
| |
| -- Expand_Dispatching_Call 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; |
| |
| -- 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 Etype (Ctrl_Arg) = RTE (RE_Tag) |
| or else (RTE_Available (RE_Interface_Tag) |
| and then Etype (Ctrl_Arg) = RTE (RE_Interface_Tag)) |
| then |
| CW_Typ := Class_Wide_Type (Controlling_Type (Subp)); |
| |
| elsif Is_Access_Type (Etype (Ctrl_Arg)) then |
| CW_Typ := Designated_Type (Etype (Ctrl_Arg)); |
| |
| else |
| CW_Typ := Etype (Ctrl_Arg); |
| end if; |
| |
| Typ := Root_Type (CW_Typ); |
| |
| if Ekind (Typ) = E_Incomplete_Type then |
| Typ := Non_Limited_View (Typ); |
| end if; |
| |
| if not Is_Limited_Type (Typ) then |
| Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq); |
| end if; |
| |
| if Is_CPP_Class (Root_Type (Typ)) then |
| |
| -- Create a new parameter list with the displaced 'this' |
| |
| New_Params := New_List; |
| Param := First_Actual (Call_Node); |
| while Present (Param) loop |
| Append_To (New_Params, Relocate_Node (Param)); |
| Next_Actual (Param); |
| end loop; |
| |
| elsif Present (Param_List) then |
| |
| -- Generate the Tag checks when appropriate |
| |
| New_Params := New_List; |
| Param := First_Actual (Call_Node); |
| while Present (Param) loop |
| |
| -- No tag check with itself |
| |
| if Param = Ctrl_Arg then |
| Append_To (New_Params, |
| Duplicate_Subexpr_Move_Checks (Param)); |
| |
| -- No tag check for parameter whose type is neither tagged nor |
| -- access to tagged (for access parameters) |
| |
| elsif No (Find_Controlling_Arg (Param)) then |
| Append_To (New_Params, Relocate_Node (Param)); |
| |
| -- 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 |
| Append_To (New_Params, Relocate_Node (Param)); |
| |
| -- "=" 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 |
| Append_To (New_Params, |
| Duplicate_Subexpr_Move_Checks (Param)); |
| |
| -- 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 |
| Append_To (New_Params, Relocate_Node (Param)); |
| |
| -- 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 |
| Append_To (New_Params, Relocate_Node (Param)); |
| |
| -- 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_Reference_To |
| (First_Tag_Component (Typ), Loc)), |
| |
| Right_Opnd => |
| Make_Selected_Component (Loc, |
| Prefix => |
| Unchecked_Convert_To (Typ, New_Value (Param)), |
| Selector_Name => |
| New_Reference_To |
| (First_Tag_Component (Typ), Loc))), |
| |
| Then_Statements => |
| New_List (New_Constraint_Error (Loc)))); |
| |
| Append_To (New_Params, Relocate_Node (Param)); |
| end if; |
| |
| Next_Actual (Param); |
| end loop; |
| end if; |
| |
| -- Generate the appropriate subprogram pointer type |
| |
| if Etype (Subp) = Typ then |
| Res_Typ := CW_Typ; |
| else |
| Res_Typ := Etype (Subp); |
| end if; |
| |
| Subp_Typ := Create_Itype (E_Subprogram_Type, Call_Node); |
| Subp_Ptr_Typ := Create_Itype (E_Access_Subprogram_Type, Call_Node); |
| Set_Etype (Subp_Typ, Res_Typ); |
| Init_Size_Align (Subp_Ptr_Typ); |
| Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp)); |
| |
| -- 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; |
| Extra : Entity_Id; |
| |
| 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 Is_Itype (Etype (New_Formal)) then |
| Extra := New_Copy (Etype (New_Formal)); |
| |
| if Ekind (Extra) = E_Record_Subtype |
| or else Ekind (Extra) = E_Class_Wide_Subtype |
| then |
| Set_Cloned_Subtype (Extra, Etype (New_Formal)); |
| end if; |
| |
| Set_Etype (New_Formal, Extra); |
| Set_Scope (Etype (New_Formal), Subp_Typ); |
| end if; |
| |
| Extra := New_Formal; |
| Next_Formal (Old_Formal); |
| exit when No (Old_Formal); |
| |
| Set_Next_Entity (New_Formal, New_Copy (Old_Formal)); |
| Next_Entity (New_Formal); |
| Next_Actual (Param); |
| end loop; |
| Set_Last_Entity (Subp_Typ, Extra); |
| |
| -- Copy extra formals |
| |
| New_Formal := First_Entity (Subp_Typ); |
| while Present (New_Formal) loop |
| if Present (Extra_Constrained (New_Formal)) then |
| Set_Extra_Formal (Extra, |
| New_Copy (Extra_Constrained (New_Formal))); |
| Extra := Extra_Formal (Extra); |
| Set_Extra_Constrained (New_Formal, Extra); |
| |
| elsif Present (Extra_Accessibility (New_Formal)) then |
| Set_Extra_Formal (Extra, |
| New_Copy (Extra_Accessibility (New_Formal))); |
| Extra := Extra_Formal (Extra); |
| Set_Extra_Accessibility (New_Formal, Extra); |
| end if; |
| |
| Next_Formal (New_Formal); |
| end loop; |
| end if; |
| end; |
| |
| Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ); |
| Set_Directly_Designated_Type (Subp_Ptr_Typ, Subp_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 Etype (Ctrl_Arg) = RTE (RE_Tag) |
| or else (RTE_Available (RE_Interface_Tag) |
| and then Etype (Ctrl_Arg) = RTE (RE_Interface_Tag)) |
| then |
| Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg); |
| |
| -- Ada 2005 (AI-251): Abstract interface class-wide type |
| |
| elsif Is_Interface (Etype (Ctrl_Arg)) |
| and then Is_Class_Wide_Type (Etype (Ctrl_Arg)) |
| then |
| Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg); |
| |
| else |
| Controlling_Tag := |
| Make_Selected_Component (Loc, |
| Prefix => Duplicate_Subexpr_Move_Checks (Ctrl_Arg), |
| Selector_Name => New_Reference_To (DTC_Entity (Subp), Loc)); |
| end if; |
| |
| -- Generate: |
| -- Subp_Ptr_Typ!(Get_Prim_Op_Address (Ctrl._Tag, pos)); |
| |
| if Is_Predefined_Dispatching_Operation (Subp) then |
| New_Call_Name := |
| Unchecked_Convert_To (Subp_Ptr_Typ, |
| Make_DT_Access_Action (Typ, |
| Action => Get_Predefined_Prim_Op_Address, |
| Args => New_List ( |
| |
| -- Vptr |
| |
| Unchecked_Convert_To (RTE (RE_Tag), |
| Controlling_Tag), |
| |
| -- Position |
| |
| Make_Integer_Literal (Loc, DT_Position (Subp))))); |
| |
| else |
| New_Call_Name := |
| Unchecked_Convert_To (Subp_Ptr_Typ, |
| Make_DT_Access_Action (Typ, |
| Action => Get_Prim_Op_Address, |
| Args => New_List ( |
| |
| -- Vptr |
| |
| Unchecked_Convert_To (RTE (RE_Tag), |
| Controlling_Tag), |
| |
| -- Position |
| |
| Make_Integer_Literal (Loc, DT_Position (Subp))))); |
| end if; |
| |
| if Nkind (Call_Node) = N_Function_Call then |
| |
| -- Ada 2005 (AI-251): A dispatching "=" with an abstract interface |
| -- just requires the comparison of the tags. |
| |
| if Ekind (Etype (Ctrl_Arg)) = E_Class_Wide_Type |
| and then Is_Interface (Etype (Ctrl_Arg)) |
| and then Subp = Eq_Prim_Op |
| then |
| Param := First_Actual (Call_Node); |
| |
| New_Call := |
| Make_Op_Eq (Loc, |
| Left_Opnd => |
| Make_Selected_Component (Loc, |
| Prefix => New_Value (Param), |
| Selector_Name => |
| New_Reference_To (First_Tag_Component (Typ), Loc)), |
| |
| Right_Opnd => |
| Make_Selected_Component (Loc, |
| Prefix => |
| Unchecked_Convert_To (Typ, |
| New_Value (Next_Actual (Param))), |
| Selector_Name => |
| New_Reference_To (First_Tag_Component (Typ), Loc))); |
| |
| else |
| 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_Reference_To (First_Tag_Component (Typ), |
| Loc)), |
| |
| Right_Opnd => |
| Make_Selected_Component (Loc, |
| Prefix => |
| Unchecked_Convert_To (Typ, |
| New_Value (Next_Actual (Param))), |
| Selector_Name => |
| New_Reference_To (First_Tag_Component (Typ), |
| Loc))), |
| Right_Opnd => New_Call); |
| end if; |
| end if; |
| |
| else |
| New_Call := |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Call_Name, |
| Parameter_Associations => New_Params); |
| end if; |
| |
| Rewrite (Call_Node, New_Call); |
| Analyze_And_Resolve (Call_Node, Call_Typ); |
| end Expand_Dispatching_Call; |
| |
| --------------------------------- |
| -- Expand_Interface_Conversion -- |
| --------------------------------- |
| |
| procedure Expand_Interface_Conversion |
| (N : Node_Id; |
| Is_Static : Boolean := True) |
| is |
| Loc : constant Source_Ptr := Sloc (N); |
| Operand : constant Node_Id := Expression (N); |
| Operand_Typ : Entity_Id := Etype (Operand); |
| Iface_Typ : Entity_Id := Etype (N); |
| Iface_Tag : Entity_Id; |
| Fent : Entity_Id; |
| Func : Node_Id; |
| P : Node_Id; |
| Null_Op_Nod : Node_Id; |
| |
| begin |
| pragma Assert (Nkind (Operand) /= N_Attribute_Reference); |
| |
| -- Ada 2005 (AI-345): Handle task interfaces |
| |
| if Ekind (Operand_Typ) = E_Task_Type |
| or else Ekind (Operand_Typ) = E_Protected_Type |
| then |
| Operand_Typ := Corresponding_Record_Type (Operand_Typ); |
| end if; |
| |
| -- Handle access types to interfaces |
| |
| if Is_Access_Type (Iface_Typ) then |
| Iface_Typ := Etype (Directly_Designated_Type (Iface_Typ)); |
| end if; |
| |
| -- Handle class-wide interface types. This conversion can appear |
| -- explicitly in the source code. Example: I'Class (Obj) |
| |
| if Is_Class_Wide_Type (Iface_Typ) then |
| Iface_Typ := Etype (Iface_Typ); |
| end if; |
| |
| pragma Assert (not Is_Class_Wide_Type (Iface_Typ) |
| and then Is_Interface (Iface_Typ)); |
| |
| 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 ("abstract interface types", N); |
| return; |
| end if; |
| |
| Rewrite (N, |
| Make_Function_Call (Loc, |
| Name => New_Reference_To (RTE (RE_Displace), Loc), |
| Parameter_Associations => New_List ( |
| Make_Attribute_Reference (Loc, |
| Prefix => Relocate_Node (Expression (N)), |
| Attribute_Name => Name_Address), |
| New_Occurrence_Of |
| (Node (First_Elmt (Access_Disp_Table (Iface_Typ))), |
| Loc)))); |
| |
| Analyze (N); |
| |
| -- Change the type of the data returned by IW_Convert to |
| -- indicate that this is a dispatching call. |
| |
| declare |
| New_Itype : Entity_Id; |
| |
| begin |
| New_Itype := Create_Itype (E_Anonymous_Access_Type, N); |
| Set_Etype (New_Itype, New_Itype); |
| Init_Size_Align (New_Itype); |
| Set_Directly_Designated_Type (New_Itype, |
| Class_Wide_Type (Iface_Typ)); |
| |
| Rewrite (N, Make_Explicit_Dereference (Loc, |
| Unchecked_Convert_To (New_Itype, |
| Relocate_Node (N)))); |
| Analyze (N); |
| end; |
| |
| return; |
| end if; |
| |
| Iface_Tag := Find_Interface_Tag (Operand_Typ, Iface_Typ); |
| pragma Assert (Iface_Tag /= Empty); |
| |
| -- Keep separate access types to interfaces because one internal |
| -- function is used to handle the null value (see following comment) |
| |
| if not Is_Access_Type (Etype (N)) then |
| Rewrite (N, |
| Unchecked_Convert_To (Etype (N), |
| Make_Selected_Component (Loc, |
| Prefix => Relocate_Node (Expression (N)), |
| Selector_Name => |
| New_Occurrence_Of (Iface_Tag, Loc)))); |
| |
| else |
| -- Build internal function to handle the case in which the |
| -- actual is null. If the actual is null returns null because |
| -- no displacement is required; otherwise performs a type |
| -- conversion that will be expanded in the code that returns |
| -- the value of the displaced actual. That is: |
| |
| -- function Func (O : Operand_Typ) return Iface_Typ is |
| -- begin |
| -- if O = null then |
| -- return null; |
| -- else |
| -- return Iface_Typ!(O); |
| -- end if; |
| -- end Func; |
| |
| Fent := |
| Make_Defining_Identifier (Loc, New_Internal_Name ('F')); |
| |
| -- Decorate the "null" in the if-statement condition |
| |
| Null_Op_Nod := Make_Null (Loc); |
| Set_Etype (Null_Op_Nod, Etype (Operand)); |
| Set_Analyzed (Null_Op_Nod); |
| |
| Func := |
| Make_Subprogram_Body (Loc, |
| Specification => |
| Make_Function_Specification (Loc, |
| Defining_Unit_Name => Fent, |
| |
| Parameter_Specifications => New_List ( |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uO), |
| Parameter_Type => |
| New_Reference_To (Etype (Operand), Loc))), |
| Result_Definition => |
| New_Reference_To (Etype (N), Loc)), |
| |
| Declarations => Empty_List, |
| |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => New_List ( |
| Make_If_Statement (Loc, |
| Condition => |
| Make_Op_Eq (Loc, |
| Left_Opnd => Make_Identifier (Loc, Name_uO), |
| Right_Opnd => Null_Op_Nod), |
| Then_Statements => New_List ( |
| Make_Return_Statement (Loc, |
| Make_Null (Loc))), |
| Else_Statements => New_List ( |
| Make_Return_Statement (Loc, |
| Unchecked_Convert_To (Etype (N), |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| Make_Selected_Component (Loc, |
| Prefix => Make_Identifier (Loc, Name_uO), |
| Selector_Name => |
| New_Occurrence_Of (Iface_Tag, Loc)), |
| Attribute_Name => Name_Address)))))))); |
| |
| -- Insert the new declaration in the nearest enclosing scope |
| -- that has declarations. |
| |
| P := N; |
| while not Has_Declarations (Parent (P)) loop |
| P := Parent (P); |
| end loop; |
| |
| if Is_List_Member (P) then |
| Insert_Before (P, Func); |
| |
| elsif Nkind (Parent (P)) = N_Package_Specification then |
| Append_To (Visible_Declarations (Parent (P)), Func); |
| |
| else |
| Append_To (Declarations (Parent (P)), Func); |
| end if; |
| |
| Analyze (Func); |
| |
| Rewrite (N, |
| Make_Function_Call (Loc, |
| Name => New_Reference_To (Fent, Loc), |
| Parameter_Associations => New_List ( |
| Relocate_Node (Expression (N))))); |
| end if; |
| |
| Analyze (N); |
| end Expand_Interface_Conversion; |
| |
| ------------------------------ |
| -- Expand_Interface_Actuals -- |
| ------------------------------ |
| |
| procedure Expand_Interface_Actuals (Call_Node : Node_Id) is |
| Loc : constant Source_Ptr := Sloc (Call_Node); |
| Actual : Node_Id; |
| Actual_Dup : Node_Id; |
| Actual_Typ : Entity_Id; |
| Anon : Entity_Id; |
| Conversion : Node_Id; |
| Formal : Entity_Id; |
| Formal_Typ : Entity_Id; |
| Subp : Entity_Id; |
| Nam : Name_Id; |
| Formal_DDT : Entity_Id; |
| Actual_DDT : Entity_Id; |
| |
| begin |
| -- This subprogram is called directly from the semantics, so we need a |
| -- 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)); |
| |
| -- Normal case |
| |
| else |
| Subp := Entity (Name (Call_Node)); |
| end if; |
| |
| Formal := First_Formal (Subp); |
| Actual := First_Actual (Call_Node); |
| while Present (Formal) loop |
| |
| -- Ada 2005 (AI-251): Conversion to interface to force "this" |
| -- displacement. |
| |
| Formal_Typ := Etype (Etype (Formal)); |
| |
| if Ekind (Formal_Typ) = E_Record_Type_With_Private then |
| Formal_Typ := Full_View (Formal_Typ); |
| end if; |
| |
| if Is_Access_Type (Formal_Typ) then |
| Formal_DDT := Directly_Designated_Type (Formal_Typ); |
| end if; |
| |
| Actual_Typ := Etype (Actual); |
| |
| if Is_Access_Type (Actual_Typ) then |
| Actual_DDT := Directly_Designated_Type (Actual_Typ); |
| end if; |
| |
| if Is_Interface (Formal_Typ) then |
| |
| -- No need to displace the pointer if the type of the actual |
| -- is class-wide of the formal-type interface; in this case the |
| -- displacement of the pointer was already done at the point of |
| -- the call to the enclosing subprogram. This case corresponds |
| -- with the call to P (Obj) in the following example: |
| |
| -- type I is interface; |
| -- procedure P (X : I) is abstract; |
| |
| -- procedure General_Op (Obj : I'Class) is |
| -- begin |
| -- P (Obj); |
| -- end General_Op; |
| |
| if Is_Class_Wide_Type (Actual_Typ) |
| and then Etype (Actual_Typ) = Formal_Typ |
| then |
| null; |
| |
| -- No need to displace the pointer if the type of the actual is a |
| -- derivation of the formal-type interface because in this case |
| -- the interface primitives are located in the primary dispatch |
| -- table. |
| |
| elsif Is_Ancestor (Formal_Typ, Actual_Typ) then |
| null; |
| |
| else |
| Conversion := Convert_To (Formal_Typ, Relocate_Node (Actual)); |
| Rewrite (Actual, Conversion); |
| Analyze_And_Resolve (Actual, Formal_Typ); |
| end if; |
| |
| -- Anonymous access type |
| |
| elsif Is_Access_Type (Formal_Typ) |
| and then Is_Interface (Etype (Formal_DDT)) |
| and then Interface_Present_In_Ancestor |
| (Typ => Actual_DDT, |
| Iface => Etype (Formal_DDT)) |
| then |
| if Nkind (Actual) = N_Attribute_Reference |
| and then |
| (Attribute_Name (Actual) = Name_Access |
| or else Attribute_Name (Actual) = Name_Unchecked_Access) |
| then |
| Nam := Attribute_Name (Actual); |
| |
| Conversion := Convert_To (Etype (Formal_DDT), Prefix (Actual)); |
| |
| Rewrite (Actual, Conversion); |
| Analyze_And_Resolve (Actual, Etype (Formal_DDT)); |
| |
| Rewrite (Actual, |
| Unchecked_Convert_To (Formal_Typ, |
| Make_Attribute_Reference (Loc, |
| Prefix => Relocate_Node (Actual), |
| Attribute_Name => Nam))); |
| |
| Analyze_And_Resolve (Actual, Formal_Typ); |
| |
| -- No need to displace the pointer if the actual is a class-wide |
| -- type of the formal-type interface because in this case the |
| -- displacement of the pointer was already done at the point of |
| -- the call to the enclosing subprogram (this case is similar |
| -- to the example described above for the non access-type case) |
| |
| elsif Is_Class_Wide_Type (Actual_DDT) |
| and then Etype (Actual_DDT) = Formal_DDT |
| then |
| null; |
| |
| -- No need to displace the pointer if the type of the actual is a |
| -- derivation of the interface (because in this case the interface |
| -- primitives are located in the primary dispatch table) |
| |
| elsif Is_Ancestor (Formal_DDT, Actual_DDT) then |
| null; |
| |
| else |
| Actual_Dup := Relocate_Node (Actual); |
| |
| if From_With_Type (Actual_Typ) then |
| |
| -- If the type of the actual parameter comes from a limited |
| -- with-clause and the non-limited view is already available |
| -- we replace the anonymous access type by a duplicate decla |
| -- ration whose designated type is the non-limited view |
| |
| if Ekind (Actual_DDT) = E_Incomplete_Type |
| and then Present (Non_Limited_View (Actual_DDT)) |
| then |
| Anon := New_Copy (Actual_Typ); |
| |
| if Is_Itype (Anon) then |
| Set_Scope (Anon, Current_Scope); |
| end if; |
| |
| Set_Directly_Designated_Type (Anon, |
| Non_Limited_View (Actual_DDT)); |
| Set_Etype (Actual_Dup, Anon); |
| |
| elsif Is_Class_Wide_Type (Actual_DDT) |
| and then Ekind (Etype (Actual_DDT)) = E_Incomplete_Type |
| and then Present (Non_Limited_View (Etype (Actual_DDT))) |
| then |
| Anon := New_Copy (Actual_Typ); |
| |
| if Is_Itype (Anon) then |
| Set_Scope (Anon, Current_Scope); |
| end if; |
| |
| Set_Directly_Designated_Type (Anon, |
| New_Copy (Actual_DDT)); |
| Set_Class_Wide_Type (Directly_Designated_Type (Anon), |
| New_Copy (Class_Wide_Type (Actual_DDT))); |
| Set_Etype (Directly_Designated_Type (Anon), |
| Non_Limited_View (Etype (Actual_DDT))); |
| Set_Etype ( |
| Class_Wide_Type (Directly_Designated_Type (Anon)), |
| Non_Limited_View (Etype (Actual_DDT))); |
| Set_Etype (Actual_Dup, Anon); |
| end if; |
| end if; |
| |
| Conversion := Convert_To (Formal_Typ, Actual_Dup); |
| Rewrite (Actual, Conversion); |
| Analyze_And_Resolve (Actual, Formal_Typ); |
| end if; |
| end if; |
| |
| Next_Actual (Actual); |
| Next_Formal (Formal); |
| end loop; |
| end Expand_Interface_Actuals; |
| |
| ---------------------------- |
| -- Expand_Interface_Thunk -- |
| ---------------------------- |
| |
| function Expand_Interface_Thunk |
| (N : Node_Id; |
| Thunk_Alias : Entity_Id; |
| Thunk_Id : Entity_Id) return Node_Id |
| is |
| Loc : constant Source_Ptr := Sloc (N); |
| Actuals : constant List_Id := New_List; |
| Decl : constant List_Id := New_List; |
| Formals : constant List_Id := New_List; |
| Target : Entity_Id; |
| New_Code : Node_Id; |
| Formal : Node_Id; |
| New_Formal : Node_Id; |
| Decl_1 : Node_Id; |
| Decl_2 : Node_Id; |
| E : Entity_Id; |
| |
| begin |
| -- Traverse the list of alias to find the final target |
| |
| Target := Thunk_Alias; |
| while Present (Alias (Target)) loop |
| Target := Alias (Target); |
| end loop; |
| |
| -- Duplicate the formals |
| |
| Formal := First_Formal (Target); |
| E := First_Formal (N); |
| while Present (Formal) loop |
| New_Formal := Copy_Separate_Tree (Parent (Formal)); |
| |
| -- Propagate the parameter type to the copy. This is required to |
| -- properly handle the case in which the subprogram covering the |
| -- interface has been inherited: |
| |
| -- Example: |
| -- type I is interface; |
| -- procedure P (X : in I) is abstract; |
| |
| -- type T is tagged null record; |
| -- procedure P (X : T); |
| |
| -- type DT is new T and I with ... |
| |
| Set_Parameter_Type (New_Formal, New_Reference_To (Etype (E), Loc)); |
| Append_To (Formals, New_Formal); |
| |
| Next_Formal (Formal); |
| Next_Formal (E); |
| end loop; |
| |
| -- Give message if configurable run-time and Offset_To_Top unavailable |
| |
| if not RTE_Available (RE_Offset_To_Top) then |
| Error_Msg_CRT ("abstract interface types", N); |
| return Empty; |
| end if; |
| |
| if Ekind (First_Formal (Target)) = E_In_Parameter |
| and then Ekind (Etype (First_Formal (Target))) |
| = E_Anonymous_Access_Type |
| then |
| -- Generate: |
| |
| -- type T is access all <<type of the first formal>> |
| -- S1 := Storage_Offset!(First_formal) |
| -- - Offset_To_Top (First_Formal.Tag) |
| |
| -- ... and the first actual of the call is generated as T!(S1) |
| |
| Decl_2 := |
| Make_Full_Type_Declaration (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, |
| New_Internal_Name ('T')), |
| Type_Definition => |
| Make_Access_To_Object_Definition (Loc, |
| All_Present => True, |
| Null_Exclusion_Present => False, |
| Constant_Present => False, |
| Subtype_Indication => |
| New_Reference_To |
| (Directly_Designated_Type |
| (Etype (First_Formal (Target))), Loc))); |
| |
| Decl_1 := |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, |
| New_Internal_Name ('S')), |
| Constant_Present => True, |
| Object_Definition => |
| New_Reference_To (RTE (RE_Storage_Offset), Loc), |
| Expression => |
| Make_Op_Subtract (Loc, |
| Left_Opnd => |
| Unchecked_Convert_To |
| (RTE (RE_Storage_Offset), |
| New_Reference_To |
| (Defining_Identifier (First (Formals)), Loc)), |
| Right_Opnd => |
| Make_Function_Call (Loc, |
| Name => New_Reference_To (RTE (RE_Offset_To_Top), Loc), |
| Parameter_Associations => New_List ( |
| Unchecked_Convert_To |
| (RTE (RE_Address), |
| New_Reference_To |
| (Defining_Identifier (First (Formals)), Loc)))))); |
| |
| Append_To (Decl, Decl_2); |
| Append_To (Decl, Decl_1); |
| |
| -- Reference the new first actual |
| |
| Append_To (Actuals, |
| Unchecked_Convert_To |
| (Defining_Identifier (Decl_2), |
| New_Reference_To (Defining_Identifier (Decl_1), Loc))); |
| |
| else |
| -- Generate: |
| |
| -- S1 := Storage_Offset!(First_formal'Address) |
| -- - Offset_To_Top (First_Formal.Tag) |
| -- S2 := Tag_Ptr!(S3) |
| |
| Decl_1 := |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, New_Internal_Name ('S')), |
| Constant_Present => True, |
| Object_Definition => |
| New_Reference_To (RTE (RE_Storage_Offset), Loc), |
| Expression => |
| Make_Op_Subtract (Loc, |
| Left_Opnd => |
| Unchecked_Convert_To |
| (RTE (RE_Storage_Offset), |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Reference_To |
| (Defining_Identifier (First (Formals)), Loc), |
| Attribute_Name => Name_Address)), |
| Right_Opnd => |
| Make_Function_Call (Loc, |
| Name => New_Reference_To (RTE (RE_Offset_To_Top), Loc), |
| Parameter_Associations => New_List ( |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Reference_To |
| (Defining_Identifier (First (Formals)), |
| Loc), |
| Attribute_Name => Name_Address))))); |
| |
| Decl_2 := |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, New_Internal_Name ('S')), |
| Constant_Present => True, |
| Object_Definition => New_Reference_To (RTE (RE_Addr_Ptr), Loc), |
| Expression => |
| Unchecked_Convert_To |
| (RTE (RE_Addr_Ptr), |
| New_Reference_To (Defining_Identifier (Decl_1), Loc))); |
| |
| Append_To (Decl, Decl_1); |
| Append_To (Decl, Decl_2); |
| |
| -- Reference the new first actual |
| |
| Append_To (Actuals, |
| Unchecked_Convert_To |
| (Etype (First_Entity (Target)), |
| Make_Explicit_Dereference (Loc, |
| New_Reference_To (Defining_Identifier (Decl_2), Loc)))); |
| end if; |
| |
| Formal := Next (First (Formals)); |
| while Present (Formal) loop |
| Append_To (Actuals, |
| New_Reference_To (Defining_Identifier (Formal), Loc)); |
| Next (Formal); |
| end loop; |
| |
| if Ekind (Target) = E_Procedure then |
| New_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)))); |
| |
| else pragma Assert (Ekind (Target) = E_Function); |
| |
| New_Code := |
| Make_Subprogram_Body (Loc, |
| Specification => |
| Make_Function_Specification (Loc, |
| Defining_Unit_Name => Thunk_Id, |
| Parameter_Specifications => Formals, |
| Result_Definition => |
| New_Copy (Result_Definition (Parent (Target)))), |
| Declarations => Decl, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => New_List ( |
| Make_Return_Statement (Loc, |
| Make_Function_Call (Loc, |
| Name => New_Occurrence_Of (Target, Loc), |
| Parameter_Associations => Actuals))))); |
| end if; |
| |
| Analyze (New_Code); |
| return New_Code; |
| end Expand_Interface_Thunk; |
| |
| ------------------- |
| -- Fill_DT_Entry -- |
| ------------------- |
| |
| function Fill_DT_Entry |
| (Loc : Source_Ptr; |
| Prim : Entity_Id) return Node_Id |
| is |
| Typ : constant Entity_Id := Scope (DTC_Entity (Prim)); |
| DT_Ptr : constant Entity_Id := |
| Node (First_Elmt (Access_Disp_Table (Typ))); |
| Pos : constant Uint := DT_Position (Prim); |
| Tag : constant Entity_Id := First_Tag_Component (Typ); |
| |
| begin |
| pragma Assert (not Restriction_Active (No_Dispatching_Calls)); |
| |
| if Is_Predefined_Dispatching_Operation (Prim) then |
| return |
| Make_DT_Access_Action (Typ, |
| Action => Set_Predefined_Prim_Op_Address, |
| Args => New_List ( |
| Unchecked_Convert_To (RTE (RE_Tag), |
| New_Reference_To (DT_Ptr, Loc)), -- DTptr |
| |
| Make_Integer_Literal (Loc, Pos), -- Position |
| |
| Make_Attribute_Reference (Loc, -- Value |
| Prefix => New_Reference_To (Prim, Loc), |
| Attribute_Name => Name_Address))); |
| else |
| pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag)); |
| |
| return |
| Make_DT_Access_Action (Typ, |
| Action => Set_Prim_Op_Address, |
| Args => New_List ( |
| Unchecked_Convert_To (RTE (RE_Tag), |
| New_Reference_To (DT_Ptr, Loc)), -- DTptr |
| |
| Make_Integer_Literal (Loc, Pos), -- Position |
| |
| Make_Attribute_Reference (Loc, -- Value |
| Prefix => New_Reference_To (Prim, Loc), |
| Attribute_Name => Name_Address))); |
| end if; |
| end Fill_DT_Entry; |
| |
| ----------------------------- |
| -- Fill_Secondary_DT_Entry -- |
| ----------------------------- |
| |
| function Fill_Secondary_DT_Entry |
| (Loc : Source_Ptr; |
| Prim : Entity_Id; |
| Thunk_Id : Entity_Id; |
| Iface_DT_Ptr : Entity_Id) return Node_Id |
| is |
| Typ : constant Entity_Id := Scope (DTC_Entity (Alias (Prim))); |
| Iface_Prim : constant Entity_Id := Abstract_Interface_Alias (Prim); |
| Pos : constant Uint := DT_Position (Iface_Prim); |
| Tag : constant Entity_Id := |
| First_Tag_Component (Scope (DTC_Entity (Iface_Prim))); |
| |
| begin |
| if Is_Predefined_Dispatching_Operation (Prim) then |
| return |
| Make_DT_Access_Action (Typ, |
| Action => Set_Predefined_Prim_Op_Address, |
| Args => New_List ( |
| Unchecked_Convert_To (RTE (RE_Tag), |
| New_Reference_To (Iface_DT_Ptr, Loc)), -- DTptr |
| |
| Make_Integer_Literal (Loc, Pos), -- Position |
| |
| Make_Attribute_Reference (Loc, -- Value |
| Prefix => New_Reference_To (Thunk_Id, Loc), |
| Attribute_Name => Name_Address))); |
| else |
| pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag)); |
| |
| return |
| Make_DT_Access_Action (Typ, |
| Action => Set_Prim_Op_Address, |
| Args => New_List ( |
| Unchecked_Convert_To (RTE (RE_Tag), |
| New_Reference_To (Iface_DT_Ptr, Loc)), -- DTptr |
| |
| Make_Integer_Literal (Loc, Pos), -- Position |
| |
| Make_Attribute_Reference (Loc, -- Value |
| Prefix => New_Reference_To (Thunk_Id, Loc), |
| Attribute_Name => Name_Address))); |
| end if; |
| end Fill_Secondary_DT_Entry; |
| |
| --------------------------- |
| -- Get_Remotely_Callable -- |
| --------------------------- |
| |
| function Get_Remotely_Callable (Obj : Node_Id) return Node_Id is |
| Loc : constant Source_Ptr := Sloc (Obj); |
| begin |
| return Make_DT_Access_Action |
| (Typ => Etype (Obj), |
| Action => Get_Remotely_Callable, |
| Args => New_List ( |
| Make_Selected_Component (Loc, |
| Prefix => Obj, |
| Selector_Name => Make_Identifier (Loc, Name_uTag)))); |
| end Get_Remotely_Callable; |
| |
| ------------------------------------------ |
| -- Init_Predefined_Interface_Primitives -- |
| ------------------------------------------ |
| |
| function Init_Predefined_Interface_Primitives |
| (Typ : Entity_Id) return List_Id |
| is |
| Loc : constant Source_Ptr := Sloc (Typ); |
| DT_Ptr : constant Node_Id := |
| Node (First_Elmt (Access_Disp_Table (Typ))); |
| Result : constant List_Id := New_List; |
| AI : Elmt_Id; |
| |
| begin |
| -- No need to inherit primitives if we have an abstract interface |
| -- type or a concurrent type. |
| |
| if Is_Interface (Typ) |
| or else Is_Concurrent_Record_Type (Typ) |
| or else Restriction_Active (No_Dispatching_Calls) |
| then |
| return Result; |
| end if; |
| |
| AI := Next_Elmt (First_Elmt (Access_Disp_Table (Typ))); |
| while Present (AI) loop |
| |
| -- All the secondary tables inherit the dispatch table entries |
| -- associated with predefined primitives. |
| |
| -- Generate: |
| -- Inherit_DT (T'Tag, Iface'Tag, 0); |
| |
| Append_To (Result, |
| Make_DT_Access_Action (Typ, |
| Action => Inherit_DT, |
| Args => New_List ( |
| Node1 => New_Reference_To (DT_Ptr, Loc), |
| Node2 => Unchecked_Convert_To (RTE (RE_Tag), |
| New_Reference_To (Node (AI), Loc)), |
| Node3 => Make_Integer_Literal (Loc, Uint_0)))); |
| |
| Next_Elmt (AI); |
| end loop; |
| |
| return Result; |
| end Init_Predefined_Interface_Primitives; |
| |
| ---------------------------------------- |
| -- Make_Disp_Asynchronous_Select_Body -- |
| ---------------------------------------- |
| |
| function Make_Disp_Asynchronous_Select_Body |
| (Typ : Entity_Id) return Node_Id |
| is |
| Conc_Typ : Entity_Id := Empty; |
| Decls : constant List_Id := New_List; |
| DT_Ptr : Entity_Id; |
| Loc : constant Source_Ptr := Sloc (Typ); |
| Stmts : constant List_Id := New_List; |
| |
| 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_Null_Statement (Loc)))); |
| end if; |
| |
| DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); |
| |
| if Is_Concurrent_Record_Type (Typ) then |
| Conc_Typ := Corresponding_Concurrent_Type (Typ); |
| |
| -- Generate: |
| -- I : Integer := Get_Entry_Index (tag! (<type>VP), S); |
| |
| -- where I will be used to capture the entry index of the primitive |
| -- wrapper at position S. |
| |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uI), |
| Object_Definition => |
| New_Reference_To (Standard_Integer, Loc), |
| Expression => |
| Make_DT_Access_Action (Typ, |
| Action => |
| Get_Entry_Index, |
| Args => |
| New_List ( |
| Unchecked_Convert_To (RTE (RE_Tag), |
| New_Reference_To (DT_Ptr, Loc)), |
| Make_Identifier (Loc, Name_uS))))); |
| |
| if Ekind (Conc_Typ) = E_Protected_Type then |
| |
| -- Generate: |
| -- Protected_Entry_Call ( |
| -- T._object'access, |
| -- protected_entry_index! (I), |
| -- P, |
| -- Asynchronous_Call, |
| -- B); |
| |
| -- where T is the protected object, I is the entry index, P are |
| -- the wrapped parameters and B is the name of the communication |
| -- block. |
| |
| Append_To (Stmts, |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Reference_To (RTE (RE_Protected_Entry_Call), Loc), |
| Parameter_Associations => |
| New_List ( |
| |
| Make_Attribute_Reference (Loc, -- T._object'access |
| Attribute_Name => |
| Name_Unchecked_Access, |
| Prefix => |
| Make_Selected_Component (Loc, |
| Prefix => |
| Make_Identifier (Loc, Name_uT), |
| Selector_Name => |
| Make_Identifier (Loc, Name_uObject))), |
| |
| Make_Unchecked_Type_Conversion (Loc, -- entry index |
| Subtype_Mark => |
| New_Reference_To (RTE (RE_Protected_Entry_Index), Loc), |
| Expression => |
| Make_Identifier (Loc, Name_uI)), |
| |
| Make_Identifier (Loc, Name_uP), -- parameter block |
| New_Reference_To ( -- Asynchronous_Call |
| RTE (RE_Asynchronous_Call), Loc), |
| Make_Identifier (Loc, Name_uB)))); -- comm block |
| else |
| pragma Assert (Ekind (Conc_Typ) = E_Task_Type); |
| |
| -- Generate: |
| -- Protected_Entry_Call ( |
| -- T._task_id, |
| -- task_entry_index! (I), |
| -- P, |
| -- Conditional_Call, |
| -- F); |
| |
| -- where T is the task object, I is the entry index, P are the |
| -- wrapped parameters and F is the status flag. |
| |
| Append_To (Stmts, |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Reference_To (RTE (RE_Task_Entry_Call), Loc), |
| Parameter_Associations => |
| New_List ( |
| |
| Make_Selected_Component (Loc, -- T._task_id |
| Prefix => |
| Make_Identifier (Loc, Name_uT), |
| Selector_Name => |
| Make_Identifier (Loc, Name_uTask_Id)), |
| |
| Make_Unchecked_Type_Conversion (Loc, -- entry index |
| Subtype_Mark => |
| New_Reference_To (RTE (RE_Task_Entry_Index), Loc), |
| Expression => |
| Make_Identifier (Loc, Name_uI)), |
| |
| Make_Identifier (Loc, Name_uP), -- parameter block |
| New_Reference_To ( -- Asynchronous_Call |
| RTE (RE_Asynchronous_Call), Loc), |
| Make_Identifier (Loc, Name_uF)))); -- status flag |
| end if; |
| 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); |
| Def_Id : constant Node_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" - Object parameter |
| -- "S" - Primitive operation slot |
| -- "P" - Wrapped parameters |
| -- "B" - Communication block |
| -- "F" - Status flag |
| |
| SEU.Build_T (Loc, Typ, Params); |
| SEU.Build_S (Loc, Params); |
| SEU.Build_P (Loc, Params); |
| SEU.Build_B (Loc, Params); |
| SEU.Build_F (Loc, Params); |
| |
| Set_Is_Internal (Def_Id); |
| |
| return |
| Make_Procedure_Specification (Loc, |
| Defining_Unit_Name => Def_Id, |
| Parameter_Specifications => Params); |
| end Make_Disp_Asynchronous_Select_Spec; |
| |
| --------------------------------------- |
| -- Make_Disp_Conditional_Select_Body -- |
| --------------------------------------- |
| |
| function Make_Disp_Conditional_Select_Body |
| (Typ : Entity_Id) return Node_Id |
| is |
| Loc : constant Source_Ptr := Sloc (Typ); |
| Blk_Nam : Entity_Id; |
| Conc_Typ : Entity_Id := Empty; |
| Decls : constant List_Id := New_List; |
| DT_Ptr : Entity_Id; |
| Stmts : constant List_Id := New_List; |
| |
| 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_Null_Statement (Loc)))); |
| end if; |
| |
| DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); |
| |
| 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_Reference_To (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; |
| |
| SEU.Build_Common_Dispatching_Select_Statements |
| (Loc, Typ, DT_Ptr, 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_Defining_Identifier (Loc, New_Internal_Name ('B')); |
| |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => |
| Blk_Nam, |
| Object_Definition => |
| New_Reference_To (RTE (RE_Communication_Block), Loc))); |
| |
| -- Generate: |
| -- I := Get_Entry_Index (tag! (<type>VP), S); |
| |
| -- I is the entry index and S is the dispatch table slot |
| |
| Append_To (Stmts, |
| Make_Assignment_Statement (Loc, |
| Name => |
| Make_Identifier (Loc, Name_uI), |
| Expression => |
| Make_DT_Access_Action (Typ, |
| Action => |
| Get_Entry_Index, |
| Args => |
| New_List ( |
| Unchecked_Convert_To (RTE (RE_Tag), |
| New_Reference_To (DT_Ptr, Loc)), |
| Make_Identifier (Loc, Name_uS))))); |
| |
| if Ekind (Conc_Typ) = E_Protected_Type then |
| |
| -- Generate: |
| -- Protected_Entry_Call ( |
| -- T._object'access, |
| -- protected_entry_index! (I), |
| -- P, |
| -- Conditional_Call, |
| -- Bnn); |
| |
| -- where T is the protected object, I is the entry index, P are |
| -- the wrapped parameters and Bnn is the name of the communication |
| -- block. |
| |
| Append_To (Stmts, |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Reference_To (RTE (RE_Protected_Entry_Call), Loc), |
| Parameter_Associations => |
| New_List ( |
| |
| Make_Attribute_Reference (Loc, -- T._object'access |
| Attribute_Name => |
| Name_Unchecked_Access, |
| Prefix => |
| Make_Selected_Component (Loc, |
| Prefix => |
| Make_Identifier (Loc, Name_uT), |
| Selector_Name => |
| Make_Identifier (Loc, Name_uObject))), |
| |
| Make_Unchecked_Type_Conversion (Loc, -- entry index |
| Subtype_Mark => |
| New_Reference_To (RTE (RE_Protected_Entry_Index), Loc), |
| Expression => |
| Make_Identifier (Loc, Name_uI)), |
| |
| Make_Identifier (Loc, Name_uP), -- parameter block |
| New_Reference_To ( -- Conditional_Call |
| RTE (RE_Conditional_Call), Loc), |
| New_Reference_To ( -- Bnn |
| Blk_Nam, Loc)))); |
| |
| -- Generate: |
| -- F := not Cancelled (Bnn); |
| |
| -- where F is the success flag. The status of Cancelled is negated |
| -- in order to match the behaviour of the version for task types. |
| |
| Append_To (Stmts, |
| Make_Assignment_Statement (Loc, |
| Name => |
| Make_Identifier (Loc, Name_uF), |
| Expression => |
| Make_Op_Not (Loc, |
| Right_Opnd => |
| Make_Function_Call (Loc, |
| Name => |
| New_Reference_To (RTE (RE_Cancelled), Loc), |
| Parameter_Associations => |
| New_List ( |
| New_Reference_To (Blk_Nam, Loc)))))); |
| else |
| pragma Assert (Ekind (Conc_Typ) = E_Task_Type); |
| |
| -- Generate: |
| -- Protected_Entry_Call ( |
| -- T._task_id, |
| -- task_entry_index! (I), |
| -- P, |
| -- Conditional_Call, |
| -- F); |
| |
| -- where T is the task object, I is the entry index, P are the |
| -- wrapped parameters and F is the status flag. |
| |
| Append_To (Stmts, |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Reference_To (RTE (RE_Task_Entry_Call), Loc), |
| Parameter_Associations => |
| New_List ( |
| |
| Make_Selected_Component (Loc, -- T._task_id |
| Prefix => |
| Make_Identifier (Loc, Name_uT), |
| Selector_Name => |
| Make_Identifier (Loc, Name_uTask_Id)), |
| |
| Make_Unchecked_Type_Conversion (Loc, -- entry index |
| Subtype_Mark => |
| New_Reference_To (RTE (RE_Task_Entry_Index), Loc), |
| Expression => |
| Make_Identifier (Loc, Name_uI)), |
| |
| Make_Identifier (Loc, Name_uP), -- parameter block |
| New_Reference_To ( -- Conditional_Call |
| RTE (RE_Conditional_Call), Loc), |
| Make_Identifier (Loc, Name_uF)))); -- status flag |
| end if; |
| 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" - Object parameter |
| -- "S" - Primitive operation slot |
| -- "P" - Wrapped parameters |
| -- "C" - Call kind |
| -- "F" - Status flag |
| |
| SEU.Build_T (Loc, Typ, Params); |
| SEU.Build_S (Loc, Params); |
| SEU.Build_P (Loc, Params); |
| SEU.Build_C (Loc, Params); |
| SEU.Build_F (Loc, Params); |
| |
| Set_Is_Internal (Def_Id); |
| |
| 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); |
| DT_Ptr : Entity_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; |
| |
| DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); |
| |
| -- Generate: |
| -- C := get_prim_op_kind (tag! (<type>VP), S); |
| |
| -- where C is the out parameter capturing the call kind and S is the |
| -- dispatch table slot number. |
| |
| return |
| Make_Subprogram_Body (Loc, |
| Specification => |
| Make_Disp_Get_Prim_Op_Kind_Spec (Typ), |
| Declarations => |
| 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_DT_Access_Action (Typ, |
| Action => |
| Get_Prim_Op_Kind, |
| Args => |
| New_List ( |
| Unchecked_Convert_To (RTE (RE_Tag), |
| New_Reference_To (DT_Ptr, Loc)), |
| Make_Identifier (Loc, Name_uS))))))); |
| end Make_Disp_Get_Prim_Op_Kind_Body; |
| |
| ------------------------------------- |
| -- Make_Disp_Get_Prim_Op_Kind_Spec -- |
| ------------------------------------- |
| |
| function Make_Disp_Get_Prim_Op_Kind_Spec |
| (Typ : Entity_Id) return Node_Id |
| is |
| Loc : constant Source_Ptr := Sloc (Typ); |
| 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" - Object parameter |
| -- "S" - Primitive operation slot |
| -- "C" - Call kind |
| |
| SEU.Build_T (Loc, Typ, Params); |
| SEU.Build_S (Loc, Params); |
| SEU.Build_C (Loc, Params); |
| |
| Set_Is_Internal (Def_Id); |
| |
| 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 |
| Ret := |
| Make_Return_Statement (Loc, |
| Expression => |
| 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 |
| Ret := |
| Make_Return_Statement (Loc, |
| Expression => |
| New_Reference_To (RTE (RO_ST_Null_Task), 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); |
| Def_Id : constant Node_Id := |
| Make_Defining_Identifier (Loc, |
| Name_uDisp_Get_Task_Id); |
| |
| begin |
| pragma Assert (not Restriction_Active (No_Dispatching_Calls)); |
| |
| Set_Is_Internal (Def_Id); |
| |
| return |
| Make_Function_Specification (Loc, |
| Defining_Unit_Name => Def_Id, |
| Parameter_Specifications => New_List ( |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uT), |
| Parameter_Type => |
| New_Reference_To (Typ, Loc))), |
| Result_Definition => |
| New_Reference_To (RTE (RO_ST_Task_Id), Loc)); |
| end Make_Disp_Get_Task_Id_Spec; |
| |
| --------------------------------- |
| -- Make_Disp_Timed_Select_Body -- |
| --------------------------------- |
| |
| function Make_Disp_Timed_Select_Body |
| (Typ : Entity_Id) return Node_Id |
| is |
| Loc : constant Source_Ptr := Sloc (Typ); |
| Conc_Typ : Entity_Id := Empty; |
| Decls : constant List_Id := New_List; |
| DT_Ptr : Entity_Id; |
| Stmts : constant List_Id := New_List; |
| |
| 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_Null_Statement (Loc)))); |
| end if; |
| |
| DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); |
| |
| 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_Reference_To (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; |
| |
| SEU.Build_Common_Dispatching_Select_Statements |
| (Loc, Typ, DT_Ptr, Stmts); |
| |
| -- Generate: |
| -- I := Get_Entry_Index (tag! (<type>VP), S); |
| |
| -- I is the entry index and S is the dispatch table slot |
| |
| Append_To (Stmts, |
| Make_Assignment_Statement (Loc, |
| Name => |
| Make_Identifier (Loc, Name_uI), |
| Expression => |
| Make_DT_Access_Action (Typ, |
| Action => |
| Get_Entry_Index, |
| Args => |
| New_List ( |
| Unchecked_Convert_To (RTE (RE_Tag), |
| New_Reference_To (DT_Ptr, Loc)), |
| Make_Identifier (Loc, Name_uS))))); |
| |
| if Ekind (Conc_Typ) = E_Protected_Type then |
| |
| -- Generate: |
| -- Timed_Protected_Entry_Call ( |
| -- T._object'access, |
| -- protected_entry_index! (I), |
| -- P, |
| -- D, |
| -- M, |
| -- F); |
| |
| -- where T is the protected object, I is the entry index, P are |
| -- the wrapped parameters, D is the delay amount, M is the delay |
| -- mode and F is the status flag. |
| |
| Append_To (Stmts, |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Reference_To (RTE (RE_Timed_Protected_Entry_Call), Loc), |
| Parameter_Associations => |
| New_List ( |
| |
| Make_Attribute_Reference (Loc, -- T._object'access |
| Attribute_Name => |
| Name_Unchecked_Access, |
| Prefix => |
| Make_Selected_Component (Loc, |
| Prefix => |
| Make_Identifier (Loc, Name_uT), |
| Selector_Name => |
| Make_Identifier (Loc, Name_uObject))), |
| |
| Make_Unchecked_Type_Conversion (Loc, -- entry index |
| Subtype_Mark => |
| New_Reference_To (RTE (RE_Protected_Entry_Index), Loc), |
| Expression => |
| Make_Identifier (Loc, Name_uI)), |
| |
| Make_Identifier (Loc, Name_uP), -- parameter block |
| Make_Identifier (Loc, Name_uD), -- delay |
| Make_Identifier (Loc, Name_uM), -- delay mode |
| Make_Identifier (Loc, Name_uF)))); -- status flag |
| |
| else |
| pragma Assert (Ekind (Conc_Typ) = E_Task_Type); |
| |
| -- Generate: |
| -- Timed_Task_Entry_Call ( |
| -- T._task_id, |
| -- task_entry_index! (I), |
| -- P, |
| -- D, |
| -- M, |
| -- F); |
| |
| -- where T is the task object, I is the entry index, P are the |
| -- wrapped parameters, D is the delay amount, M is the delay |
| -- mode and F is the status flag. |
| |
| Append_To (Stmts, |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Reference_To (RTE (RE_Timed_Task_Entry_Call), Loc), |
| Parameter_Associations => |
| New_List ( |
| |
| Make_Selected_Component (Loc, -- T._task_id |
| Prefix => |
| Make_Identifier (Loc, Name_uT), |
| Selector_Name => |
| Make_Identifier (Loc, Name_uTask_Id)), |
| |
| Make_Unchecked_Type_Conversion (Loc, -- entry index |
| Subtype_Mark => |
| New_Reference_To (RTE (RE_Task_Entry_Index), Loc), |
| Expression => |
| Make_Identifier (Loc, Name_uI)), |
| |
| Make_Identifier (Loc, Name_uP), -- parameter block |
| Make_Identifier (Loc, Name_uD), -- delay |
| Make_Identifier (Loc, Name_uM), -- delay mode |
| Make_Identifier (Loc, Name_uF)))); -- status flag |
| end if; |
| 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" - Object parameter |
| -- "S" - Primitive operation slot |
| -- "P" - Wrapped parameters |
| -- "D" - Delay |
| -- "M" - Delay Mode |
| -- "C" - Call kind |
| -- "F" - Status flag |
| |
| SEU.Build_T (Loc, Typ, Params); |
| SEU.Build_S (Loc, Params); |
| SEU.Build_P (Loc, Params); |
| |
| Append_To (Params, |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uD), |
| Parameter_Type => |
| New_Reference_To (Standard_Duration, Loc))); |
| |
| Append_To (Params, |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uM), |
| Parameter_Type => |
| New_Reference_To (Standard_Integer, Loc))); |
| |
| SEU.Build_C (Loc, Params); |
| SEU.Build_F (Loc, Params); |
| |
| Set_Is_Internal (Def_Id); |
| |
| return |
| Make_Procedure_Specification (Loc, |
| Defining_Unit_Name => Def_Id, |
| Parameter_Specifications => Params); |
| end Make_Disp_Timed_Select_Spec; |
| |
| ------------- |
| -- Make_DT -- |
| ------------- |
| |
| function Make_DT (Typ : Entity_Id) return List_Id is |
| Loc : constant Source_Ptr := Sloc (Typ); |
| Result : constant List_Id := New_List; |
| Elab_Code : constant List_Id := New_List; |
| |
| Tname : constant Name_Id := Chars (Typ); |
| Name_DT : constant Name_Id := New_External_Name (Tname, 'T'); |
| Name_DT_Ptr : constant Name_Id := New_External_Name (Tname, 'P'); |
| Name_SSD : constant Name_Id := New_External_Name (Tname, 'S'); |
| Name_TSD : constant Name_Id := New_External_Name (Tname, 'B'); |
| Name_Exname : constant Name_Id := New_External_Name (Tname, 'E'); |
| Name_No_Reg : constant Name_Id := New_External_Name (Tname, 'F'); |
| Name_ITable : Name_Id; |
| |
| DT : constant Node_Id := Make_Defining_Identifier (Loc, Name_DT); |
| DT_Ptr : constant Node_Id := Make_Defining_Identifier (Loc, Name_DT_Ptr); |
| SSD : constant Node_Id := Make_Defining_Identifier (Loc, Name_SSD); |
| TSD : constant Node_Id := Make_Defining_Identifier (Loc, Name_TSD); |
| Exname : constant Node_Id := Make_Defining_Identifier (Loc, Name_Exname); |
| No_Reg : constant Node_Id := Make_Defining_Identifier (Loc, Name_No_Reg); |
| ITable : Node_Id; |
| |
| Generalized_Tag : constant Entity_Id := RTE (RE_Tag); |
| AI : Elmt_Id; |
| I_Depth : Int; |
| Nb_Prim : Int; |
| Num_Ifaces : Int; |
| Old_Tag1 : Node_Id; |
| Old_Tag2 : Node_Id; |
| Parent_Num_Ifaces : Int; |
| Size_Expr_Node : Node_Id; |
| TSD_Num_Entries : Int; |
| |
| Ancestor_Copy : Entity_Id; |
| Empty_DT : Boolean := False; |
| Typ_Copy : Entity_Id; |
| |
| begin |
| if not RTE_Available (RE_Tag) then |
| Error_Msg_CRT ("tagged types", Typ); |
| return New_List; |
| end if; |
| |
| -- Calculate the size of the DT and the TSD |
| |
| if Is_Interface (Typ) then |
| |
| -- Abstract interfaces need neither the DT nor the ancestors table. |
| -- We reserve a single entry for its DT because at run-time the |
| -- pointer to this dummy DT will be used as the tag of this abstract |
| -- interface type. |
| |
| Empty_DT := True; |
| Nb_Prim := 1; |
| TSD_Num_Entries := 0; |
| Num_Ifaces := 0; |
| |
| else |
| -- Count the number of interfaces implemented by the ancestors |
| |
| Parent_Num_Ifaces := 0; |
| Num_Ifaces := 0; |
| |
| if Typ /= Etype (Typ) then |
| Ancestor_Copy := New_Copy (Etype (Typ)); |
| Set_Parent (Ancestor_Copy, Parent (Etype (Typ))); |
| Set_Abstract_Interfaces (Ancestor_Copy, New_Elmt_List); |
| Collect_All_Interfaces (Ancestor_Copy); |
| |
| AI := First_Elmt (Abstract_Interfaces (Ancestor_Copy)); |
| while Present (AI) loop |
| Parent_Num_Ifaces := Parent_Num_Ifaces + 1; |
| Next_Elmt (AI); |
| end loop; |
| end if; |
| |
| -- Count the number of additional interfaces implemented by Typ |
| |
| Typ_Copy := New_Copy (Typ); |
| Set_Parent (Typ_Copy, Parent (Typ)); |
| Set_Abstract_Interfaces (Typ_Copy, New_Elmt_List); |
| Collect_All_Interfaces (Typ_Copy); |
| |
| AI := First_Elmt (Abstract_Interfaces (Typ_Copy)); |
| while Present (AI) loop |
| Num_Ifaces := Num_Ifaces + 1; |
| Next_Elmt (AI); |
| end loop; |
| |
| -- Count ancestors to compute the inheritance depth. For private |
| -- extensions, always go to the full view in order to compute the |
| -- real inheritance depth. |
| |
| declare |
| Parent_Type : Entity_Id := Typ; |
| P : Entity_Id; |
| |
| begin |
| I_Depth := 0; |
| loop |
| P := Etype (Parent_Type); |
| |
| if Is_Private_Type (P) then |
| P := Full_View (Base_Type (P)); |
| end if; |
| |
| exit when P = Parent_Type; |
| |
| I_Depth := I_Depth + 1; |
| Parent_Type := P; |
| end loop; |
| end; |
| |
| TSD_Num_Entries := I_Depth + 1; |
| Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ))); |
| |
| -- If the number of primitives of Typ is 0 (or we are compiling with |
| -- the No_Dispatching_Calls restriction) we reserve a dummy single |
| -- entry for its DT because at run-time the pointer to this dummy DT |
| -- will be used as the tag of this tagged type. |
| |
| if Nb_Prim = 0 or else Restriction_Active (No_Dispatching_Calls) then |
| Empty_DT := True; |
| Nb_Prim := 1; |
| end if; |
| end if; |
| |
| -- Dispatch table and related entities are allocated statically |
| |
| Set_Ekind (DT, E_Variable); |
| Set_Is_Statically_Allocated (DT); |
| |
| Set_Ekind (DT_Ptr, E_Variable); |
| Set_Is_Statically_Allocated (DT_Ptr); |
| |
| if not Is_Interface (Typ) |
| and then Num_Ifaces > 0 |
| then |
| Name_ITable := New_External_Name (Tname, 'I'); |
| ITable := Make_Defining_Identifier (Loc, Name_ITable); |
| |
| Set_Ekind (ITable, E_Variable); |
| Set_Is_Statically_Allocated (ITable); |
| end if; |
| |
| Set_Ekind (SSD, E_Variable); |
| Set_Is_Statically_Allocated (SSD); |
| |
| Set_Ekind (TSD, E_Variable); |
| Set_Is_Statically_Allocated (TSD); |
| |
| Set_Ekind (Exname, E_Variable); |
| Set_Is_Statically_Allocated (Exname); |
| |
| Set_Ekind (No_Reg, E_Variable); |
| Set_Is_Statically_Allocated (No_Reg); |
| |
| -- Generate code to create the storage for the Dispatch_Table object: |
| |
| -- DT : Storage_Array (1..DT_Prologue_Size+nb_prim*DT_Entry_Size); |
| -- for DT'Alignment use Address'Alignment |
| |
| Size_Expr_Node := |
| Make_Op_Add (Loc, |
| Left_Opnd => Make_DT_Access_Action (Typ, DT_Prologue_Size, No_List), |
| Right_Opnd => |
| Make_Op_Multiply (Loc, |
| Left_Opnd => |
| Make_DT_Access_Action (Typ, DT_Entry_Size, No_List), |
| Right_Opnd => |
| Make_Integer_Literal (Loc, Nb_Prim))); |
| |
| Append_To (Result, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => DT, |
| Aliased_Present => True, |
| Object_Definition => |
| Make_Subtype_Indication (Loc, |
| Subtype_Mark => New_Reference_To |
| (RTE (RE_Storage_Array), Loc), |
| Constraint => Make_Index_Or_Discriminant_Constraint (Loc, |
| Constraints => New_List ( |
| Make_Range (Loc, |
| Low_Bound => Make_Integer_Literal (Loc, 1), |
| High_Bound => Size_Expr_Node)))))); |
| |
| Append_To (Result, |
| Make_Attribute_Definition_Clause (Loc, |
| Name => New_Reference_To (DT, Loc), |
| Chars => Name_Alignment, |
| Expression => |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc), |
| Attribute_Name => Name_Alignment))); |
| |
| -- Generate code to create the pointer to the dispatch table |
| |
| -- DT_Ptr : Tag := Tag!(DT'Address); |
| |
| -- According to the C++ ABI, the base of the vtable is located after a |
| -- prologue containing Offset_To_Top, and Typeinfo_Ptr. Hence, we move |
| -- down the pointer to the real base of the vtable |
| |
| Append_To (Result, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => DT_Ptr, |
| Constant_Present => True, |
| Object_Definition => New_Reference_To (Generalized_Tag, Loc), |
| Expression => |
| Unchecked_Convert_To (Generalized_Tag, |
| Make_Op_Add (Loc, |
| Left_Opnd => |
| Unchecked_Convert_To (RTE (RE_Storage_Offset), |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Reference_To (DT, Loc), |
| Attribute_Name => Name_Address)), |
| Right_Opnd => |
| Make_DT_Access_Action (Typ, |
| DT_Prologue_Size, No_List))))); |
| |
| -- Generate code to define the boolean that controls registration, in |
| -- order to avoid multiple registrations for tagged types defined in |
| -- multiple-called scopes. |
| |
| Append_To (Result, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => No_Reg, |
| Object_Definition => New_Reference_To (Standard_Boolean, Loc), |
| Expression => New_Reference_To (Standard_True, Loc))); |
| |
| -- Set Access_Disp_Table field to be the dispatch table pointer |
| |
| if No (Access_Disp_Table (Typ)) then |
| Set_Access_Disp_Table (Typ, New_Elmt_List); |
| end if; |
| |
| Prepend_Elmt (DT_Ptr, Access_Disp_Table (Typ)); |
| |
| -- Generate code to create the storage for the type specific data object |
| -- with enough space to store the tags of the ancestors plus the tags |
| -- of all the implemented interfaces (as described in a-tags.adb). |
| |
| -- TSD: Storage_Array |
| -- (1..TSD_Prologue_Size+TSD_Num_Entries*TSD_Entry_Size); |
| -- for TSD'Alignment use Address'Alignment |
| |
| Size_Expr_Node := |
| Make_Op_Add (Loc, |
| Left_Opnd => |
| Make_DT_Access_Action (Typ, TSD_Prologue_Size, No_List), |
| Right_Opnd => |
| Make_Op_Multiply (Loc, |
| Left_Opnd => |
| Make_DT_Access_Action (Typ, TSD_Entry_Size, No_List), |
| Right_Opnd => |
| Make_Integer_Literal (Loc, TSD_Num_Entries))); |
| |
| Append_To (Result, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => TSD, |
| Aliased_Present => True, |
| Object_Definition => |
| Make_Subtype_Indication (Loc, |
| Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc), |
| Constraint => Make_Index_Or_Discriminant_Constraint (Loc, |
| Constraints => New_List ( |
| Make_Range (Loc, |
| Low_Bound => Make_Integer_Literal (Loc, 1), |
| High_Bound => Size_Expr_Node)))))); |
| |
| Append_To (Result, |
| Make_Attribute_Definition_Clause (Loc, |
| Name => New_Reference_To (TSD, Loc), |
| Chars => Name_Alignment, |
| Expression => |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc), |
| Attribute_Name => Name_Alignment))); |
| |
| -- Generate: |
| -- Set_Signature (DT_Ptr, Value); |
| |
| if Is_Interface (Typ) then |
| Append_To (Elab_Code, |
| Make_DT_Access_Action (Typ, |
| Action => Set_Signature, |
| Args => New_List ( |
| New_Reference_To (DT_Ptr, Loc), -- DTptr |
| New_Reference_To (RTE (RE_Abstract_Interface), Loc)))); |
| |
| elsif RTE_Available (RE_Set_Signature) then |
| Append_To (Elab_Code, |
| Make_DT_Access_Action (Typ, |
| Action => Set_Signature, |
| Args => New_List ( |
| New_Reference_To (DT_Ptr, Loc), -- DTptr |
| New_Reference_To (RTE (RE_Primary_DT), Loc)))); |
| end if; |
| |
| -- Generate code to put the Address of the TSD in the dispatch table |
| -- Set_TSD (DT_Ptr, TSD); |
| |
| Append_To (Elab_Code, |
| Make_DT_Access_Action (Typ, |
| Action => Set_TSD, |
| Args => New_List ( |
| New_Reference_To (DT_Ptr, Loc), -- DTptr |
| Make_Attribute_Reference (Loc, -- Value |
| Prefix => New_Reference_To (TSD, Loc), |
| Attribute_Name => Name_Address)))); |
| |
| -- Set the pointer to the Interfaces_Table (if any). Otherwise the |
| -- corresponding access component is set to null. |
| |
| if Is_Interface (Typ) then |
| null; |
| |
| elsif Num_Ifaces = 0 then |
| if RTE_Available (RE_Set_Interface_Table) then |
| Append_To (Elab_Code, |
| Make_DT_Access_Action (Typ, |
| Action => Set_Interface_Table, |
| Args => New_List ( |
| New_Reference_To (DT_Ptr, Loc), -- DTptr |
| New_Reference_To (RTE (RE_Null_Address), Loc)))); -- null |
| end if; |
| |
| -- Generate the Interface_Table object and set the access |
| -- component if the TSD to it. |
| |
| elsif RTE_Available (RE_Set_Interface_Table) then |
| Append_To (Result, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => ITable, |
| Aliased_Present => True, |
| Object_Definition => |
| Make_Subtype_Indication (Loc, |
| Subtype_Mark => New_Reference_To |
| (RTE (RE_Interface_Data), Loc), |
| Constraint => Make_Index_Or_Discriminant_Constraint (Loc, |
| Constraints => New_List ( |
| Make_Integer_Literal (Loc, |
| Num_Ifaces)))))); |
| |
| Append_To (Elab_Code, |
| Make_DT_Access_Action (Typ, |
| Action => Set_Interface_Table, |
| Args => New_List ( |
| New_Reference_To (DT_Ptr, Loc), -- DTptr |
| Make_Attribute_Reference (Loc, -- Value |
| Prefix => New_Reference_To (ITable, Loc), |
| Attribute_Name => Name_Address)))); |
| end if; |
| |
| -- Generate: |
| -- Set_Num_Prim_Ops (T'Tag, Nb_Prim) |
| |
| if RTE_Available (RE_Set_Num_Prim_Ops) then |
| if not Is_Interface (Typ) then |
| if Empty_DT then |
| Append_To (Elab_Code, |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Reference_To (RTE (RE_Set_Num_Prim_Ops), Loc), |
| Parameter_Associations => New_List ( |
| New_Reference_To (DT_Ptr, Loc), |
| Make_Integer_Literal (Loc, Uint_0)))); |
| else |
| Append_To (Elab_Code, |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Reference_To (RTE (RE_Set_Num_Prim_Ops), Loc), |
| Parameter_Associations => New_List ( |
| New_Reference_To (DT_Ptr, Loc), |
| Make_Integer_Literal (Loc, Nb_Prim)))); |
| end if; |
| end if; |
| |
| if Ada_Version >= Ada_05 |
| and then not Is_Interface (Typ) |
| and then not Is_Abstract (Typ) |
| and then not Is_Controlled (Typ) |
| and then not Restriction_Active (No_Dispatching_Calls) |
| then |
| -- Generate: |
| -- Set_Type_Kind (T'Tag, Type_Kind (Typ)); |
| |
| Append_To (Elab_Code, |
| Make_DT_Access_Action (Typ, |
| Action => Set_Tagged_Kind, |
| Args => New_List ( |
| New_Reference_To (DT_Ptr, Loc), -- DTptr |
| Tagged_Kind (Typ)))); -- Value |
| |
| -- Generate the Select Specific Data table for synchronized |
| -- types that implement a synchronized interface. The size |
| -- of the table is constrained by the number of non-predefined |
| -- primitive operations. |
| |
| if not Empty_DT |
| and then Is_Concurrent_Record_Type (Typ) |
| and then Implements_Interface ( |
| Typ => Typ, |
| Kind => Any_Limited_Interface, |
| Check_Parent => True) |
| then |
| Append_To (Result, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => SSD, |
| Aliased_Present => True, |
| Object_Definition => |
| Make_Subtype_Indication (Loc, |
| Subtype_Mark => New_Reference_To ( |
| RTE (RE_Select_Specific_Data), Loc), |
| Constraint => |
| Make_Index_Or_Discriminant_Constraint (Loc, |
| Constraints => New_List ( |
| Make_Integer_Literal (Loc, Nb_Prim)))))); |
| |
| -- Set the pointer to the Select Specific Data table in the TSD |
| |
| Append_To (Elab_Code, |
| Make_DT_Access_Action (Typ, |
| Action => Set_SSD, |
| Args => New_List ( |
| New_Reference_To (DT_Ptr, Loc), -- DTptr |
| Make_Attribute_Reference (Loc, -- Value |
| Prefix => New_Reference_To (SSD, Loc), |
| Attribute_Name => Name_Address)))); |
| end if; |
| end if; |
| end if; |
| |
| -- Generate: Exname : constant String := full_qualified_name (typ); |
| -- The type itself may be an anonymous parent type, so use the first |
| -- subtype to have a user-recognizable name. |
| |
| Append_To (Result, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Exname, |
| Constant_Present => True, |
| Object_Definition => New_Reference_To (Standard_String, Loc), |
| Expression => |
| Make_String_Literal (Loc, |
| Full_Qualified_Name (First_Subtype (Typ))))); |
| |
| -- Generate: Set_Expanded_Name (DT_Ptr, exname'Address); |
| |
| Append_To (Elab_Code, |
| Make_DT_Access_Action (Typ, |
| Action => Set_Expanded_Name, |
| Args => New_List ( |
| Node1 => New_Reference_To (DT_Ptr, Loc), |
| Node2 => |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Reference_To (Exname, Loc), |
| Attribute_Name => Name_Address)))); |
| |
| if not Is_Interface (Typ) then |
| -- Generate: Set_Access_Level (DT_Ptr, <type's accessibility level>); |
| |
| Append_To (Elab_Code, |
| Make_DT_Access_Action (Typ, |
| Action => Set_Access_Level, |
| Args => New_List ( |
| Node1 => New_Reference_To (DT_Ptr, Loc), |
| Node2 => Make_Integer_Literal (Loc, Type_Access_Level (Typ))))); |
| end if; |
| |
| if Typ = Etype (Typ) |
| or else Is_CPP_Class (Etype (Typ)) |
| or else Is_Interface (Typ) |
| then |
| Old_Tag1 := |
| Unchecked_Convert_To (Generalized_Tag, |
| Make_Integer_Literal (Loc, 0)); |
| Old_Tag2 := |
| Unchecked_Convert_To (Generalized_Tag, |
| Make_Integer_Literal (Loc, 0)); |
| |
| else |
| Old_Tag1 := |
| New_Reference_To |
| (Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc); |
| Old_Tag2 := |
| New_Reference_To |
| (Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc); |
| end if; |
| |
| if Typ /= Etype (Typ) |
| and then not Is_Interface (Typ) |
| and then not Restriction_Active (No_Dispatching_Calls) |
| then |
| -- Generate: Inherit_DT (parent'tag, DT_Ptr, nb_prim of parent); |
| |
| if not Is_Interface (Etype (Typ)) then |
| if Restriction_Active (No_Dispatching_Calls) then |
| Append_To (Elab_Code, |
| Make_DT_Access_Action (Typ, |
| Action => Inherit_DT, |
| Args => New_List ( |
| Node1 => Old_Tag1, |
| Node2 => New_Reference_To (DT_Ptr, Loc), |
| Node3 => Make_Integer_Literal (Loc, Uint_0)))); |
| else |
| Append_To (Elab_Code, |
| Make_DT_Access_Action (Typ, |
| Action => Inherit_DT, |
| Args => New_List ( |
| Node1 => Old_Tag1, |
| Node2 => New_Reference_To (DT_Ptr, Loc), |
| Node3 => Make_Integer_Literal (Loc, |
| DT_Entry_Count |
| (First_Tag_Component (Etype (Typ))))))); |
| end if; |
| end if; |
| |
| -- Inherit the secondary dispatch tables of the ancestor |
| |
| if not Restriction_Active (No_Dispatching_Calls) |
| and then not Is_CPP_Class (Etype (Typ)) |
| then |
| declare |
| Sec_DT_Ancestor : Elmt_Id := |
| Next_Elmt |
| (First_Elmt |
| (Access_Disp_Table (Etype (Typ)))); |
| Sec_DT_Typ : Elmt_Id := |
| Next_Elmt |
| (First_Elmt |
| (Access_Disp_Table (Typ))); |
| |
| procedure Copy_Secondary_DTs (Typ : Entity_Id); |
| -- Local procedure required to climb through the ancestors and |
| -- copy the contents of all their secondary dispatch tables. |
| |
| ------------------------ |
| -- Copy_Secondary_DTs -- |
| ------------------------ |
| |
| procedure Copy_Secondary_DTs (Typ : Entity_Id) is |
| E : Entity_Id; |
| Iface : Elmt_Id; |
| |
| begin |
| -- Climb to the ancestor (if any) handling private types |
| |
| if Present (Full_View (Etype (Typ))) then |
| if Full_View (Etype (Typ)) /= Typ then |
| Copy_Secondary_DTs (Full_View (Etype (Typ))); |
| end if; |
| |
| elsif Etype (Typ) /= Typ then |
| Copy_Secondary_DTs (Etype (Typ)); |
| end if; |
| |
| if Present (Abstract_Interfaces (Typ)) |
| and then not Is_Empty_Elmt_List |
| (Abstract_Interfaces (Typ)) |
| then |
| Iface := First_Elmt (Abstract_Interfaces (Typ)); |
| E := First_Entity (Typ); |
| while Present (E) |
| and then Present (Node (Sec_DT_Ancestor)) |
| loop |
| if Is_Tag (E) and then Chars (E) /= Name_uTag then |
| if not Is_Interface (Etype (Typ)) then |
| Append_To (Elab_Code, |
| Make_DT_Access_Action (Typ, |
| Action => Inherit_DT, |
| Args => New_List ( |
| Node1 => Unchecked_Convert_To |
| (RTE (RE_Tag), |
| New_Reference_To |
| (Node (Sec_DT_Ancestor), |
| Loc)), |
| Node2 => Unchecked_Convert_To |
| (RTE (RE_Tag), |
| New_Reference_To |
| (Node (Sec_DT_Typ), Loc)), |
| Node3 => Make_Integer_Literal (Loc, |
| DT_Entry_Count (E))))); |
| end if; |
| |
| Next_Elmt (Sec_DT_Ancestor); |
| Next_Elmt (Sec_DT_Typ); |
| Next_Elmt (Iface); |
| end if; |
| |
| Next_Entity (E); |
| end loop; |
| end if; |
| end Copy_Secondary_DTs; |
| |
| begin |
| if Present (Node (Sec_DT_Ancestor)) then |
| |
| -- Handle private types |
| |
| if Present (Full_View (Typ)) then |
| Copy_Secondary_DTs (Full_View (Typ)); |
| else |
| Copy_Secondary_DTs (Typ); |
| end if; |
| end if; |
| end; |
| end if; |
| end if; |
| |
| -- Generate: |
| -- Inherit_TSD (parent'tag, DT_Ptr); |
| |
| Append_To (Elab_Code, |
| Make_DT_Access_Action (Typ, |
| Action => Inherit_TSD, |
| Args => New_List ( |
| Node1 => Old_Tag2, |
| Node2 => New_Reference_To (DT_Ptr, Loc)))); |
| |
| if not Is_Interface (Typ) then |
| |
| -- For types with no controlled components, generate: |
| -- Set_RC_Offset (DT_Ptr, 0); |
| |
| -- For simple types with controlled components, generate: |
| -- Set_RC_Offset (DT_Ptr, type._record_controller'position); |
| |
| -- For complex types with controlled components where the position |
| -- of the record controller is not statically computable, if there |
| -- are controlled components at this level, generate: |
| -- Set_RC_Offset (DT_Ptr, -1); |
| -- to indicate that the _controller field is right after the _parent |
| |
| -- Or if there are no controlled components at this level, generate: |
| -- Set_RC_Offset (DT_Ptr, -2); |
| -- to indicate that we need to get the position from the parent. |
| |
| declare |
| Position : Node_Id; |
| |
| begin |
| if not Has_Controlled_Component (Typ) then |
| Position := Make_Integer_Literal (Loc, 0); |
| |
| elsif Etype (Typ) /= Typ |
| and then Has_Discriminants (Etype (Typ)) |
| then |
| if Has_New_Controlled_Component (Typ) then |
| Position := Make_Integer_Literal (Loc, -1); |
| else |
| Position := Make_Integer_Literal (Loc, -2); |
| end if; |
| else |
| Position := |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| Make_Selected_Component (Loc, |
| Prefix => New_Reference_To (Typ, Loc), |
| Selector_Name => |
| New_Reference_To (Controller_Component (Typ), Loc)), |
| Attribute_Name => Name_Position); |
| |
| -- This is not proper Ada code to use the attribute 'Position |
| -- on something else than an object but this is supported by |
| -- the back end (see comment on the Bit_Component attribute in |
| -- sem_attr). So we avoid semantic checking here. |
| |
| -- Is this documented in sinfo.ads??? it should be! |
| |
| Set_Analyzed (Position); |
| Set_Etype (Prefix (Position), RTE (RE_Record_Controller)); |
| Set_Etype (Prefix (Prefix (Position)), Typ); |
| Set_Etype (Selector_Name (Prefix (Position)), |
| RTE (RE_Record_Controller)); |
| Set_Etype (Position, RTE (RE_Storage_Offset)); |
| end if; |
| |
| Append_To (Elab_Code, |
| Make_DT_Access_Action (Typ, |
| Action => Set_RC_Offset, |
| Args => New_List ( |
| Node1 => New_Reference_To (DT_Ptr, Loc), |
| Node2 => Position))); |
| end; |
| |
| -- Generate: Set_Remotely_Callable (DT_Ptr, Status); where Status is |
| -- described in E.4 (18) |
| |
| declare |
| Status : Entity_Id; |
| |
| begin |
| Status := |
| Boolean_Literals |
| (Is_Pure (Typ) |
| or else Is_Shared_Passive (Typ) |
| or else |
| ((Is_Remote_Types (Typ) |
| or else Is_Remote_Call_Interface (Typ)) |
| and then Original_View_In_Visible_Part (Typ)) |
| or else not Comes_From_Source (Typ)); |
| |
| Append_To (Elab_Code, |
| Make_DT_Access_Action (Typ, |
| Action => Set_Remotely_Callable, |
| Args => New_List ( |
| New_Occurrence_Of (DT_Ptr, Loc), |
| New_Occurrence_Of (Status, Loc)))); |
| end; |
| |
| if RTE_Available (RE_Set_Offset_To_Top) then |
| -- Generate: |
| -- Set_Offset_To_Top (0, DT_Ptr, True, 0, null); |
| |
| Append_To (Elab_Code, |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Reference_To (RTE (RE_Set_Offset_To_Top), Loc), |
| Parameter_Associations => New_List ( |
| New_Reference_To (RTE (RE_Null_Address), Loc), |
| New_Reference_To (DT_Ptr, Loc), |
| New_Occurrence_Of (Standard_True, Loc), |
| Make_Integer_Literal (Loc, Uint_0), |
| New_Reference_To (RTE (RE_Null_Address), Loc)))); |
| end if; |
| end if; |
| |
| -- Generate: Set_External_Tag (DT_Ptr, exname'Address); |
| -- Should be the external name not the qualified name??? |
| |
| if not Has_External_Tag_Rep_Clause (Typ) then |
| Append_To (Elab_Code, |
| Make_DT_Access_Action (Typ, |
| Action => Set_External_Tag, |
| Args => New_List ( |
| Node1 => New_Reference_To (DT_Ptr, Loc), |
| Node2 => |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Reference_To (Exname, Loc), |
| Attribute_Name => Name_Address)))); |
| |
| -- Generate code to register the Tag in the External_Tag hash |
| -- table for the pure Ada type only. |
| |
| -- Register_Tag (Dt_Ptr); |
| |
| -- Skip this if routine not available, or in No_Run_Time mode |
| -- or Typ is an abstract interface type (because the table to |
| -- register it is not available in the abstract type but in |
| -- types implementing this interface) |
| |
| if not No_Run_Time_Mode |
| and then RTE_Available (RE_Register_Tag) |
| and then Is_RTE (Generalized_Tag, RE_Tag) |
| and then not Is_Interface (Typ) |
| then |
| Append_To (Elab_Code, |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Reference_To (RTE (RE_Register_Tag), Loc), |
| Parameter_Associations => |
| New_List (New_Reference_To (DT_Ptr, Loc)))); |
| end if; |
| end if; |
| |
| -- Generate: |
| -- if No_Reg then |
| -- <elab_code> |
| -- No_Reg := False; |
| -- end if; |
| |
| Append_To (Elab_Code, |
| Make_Assignment_Statement (Loc, |
| Name => New_Reference_To (No_Reg, Loc), |
| Expression => New_Reference_To (Standard_False, Loc))); |
| |
| Append_To (Result, |
| Make_Implicit_If_Statement (Typ, |
| Condition => New_Reference_To (No_Reg, Loc), |
| Then_Statements => Elab_Code)); |
| |
| -- Ada 2005 (AI-251): Register the tag of the interfaces into |
| -- the table of implemented interfaces. |
| |
| if not Is_Interface (Typ) |
| and then Num_Ifaces > 0 |
| then |
| declare |
| Position : Int; |
| |
| begin |
| -- If the parent is an interface we must generate code to register |
| -- all its interfaces; otherwise this code is not needed because |
| -- Inherit_TSD has already inherited such interfaces. |
| |
| if Is_Interface (Etype (Typ)) then |
| Position := 1; |
| |
| AI := First_Elmt (Abstract_Interfaces (Ancestor_Copy)); |
| while Present (AI) loop |
| -- Generate: |
| -- Register_Interface (DT_Ptr, Interface'Tag); |
| |
| Append_To (Result, |
| Make_DT_Access_Action (Typ, |
| Action => Register_Interface_Tag, |
| Args => New_List ( |
| Node1 => New_Reference_To (DT_Ptr, Loc), |
| Node2 => New_Reference_To |
| (Node |
| (First_Elmt |
| (Access_Disp_Table (Node (AI)))), |
| Loc), |
| Node3 => Make_Integer_Literal (Loc, Position)))); |
| |
| Position := Position + 1; |
| Next_Elmt (AI); |
| end loop; |
| end if; |
| |
| -- Register the interfaces that are not implemented by the |
| -- ancestor |
| |
| if Present (Abstract_Interfaces (Typ_Copy)) then |
| AI := First_Elmt (Abstract_Interfaces (Typ_Copy)); |
| |
| -- Skip the interfaces implemented by the ancestor |
| |
| for Count in 1 .. Parent_Num_Ifaces loop |
| Next_Elmt (AI); |
| end loop; |
| |
| -- Register the additional interfaces |
| |
| Position := Parent_Num_Ifaces + 1; |
| while Present (AI) loop |
| -- Generate: |
| -- Register_Interface (DT_Ptr, Interface'Tag); |
| |
| Append_To (Result, |
| Make_DT_Access_Action (Typ, |
| Action => Register_Interface_Tag, |
| Args => New_List ( |
| Node1 => New_Reference_To (DT_Ptr, Loc), |
| Node2 => New_Reference_To |
| (Node |
| (First_Elmt |
| (Access_Disp_Table (Node (AI)))), |
| Loc), |
| Node3 => Make_Integer_Literal (Loc, Position)))); |
| |
| Position := Position + 1; |
| Next_Elmt (AI); |
| end loop; |
| end if; |
| |
| pragma Assert (Position = Num_Ifaces + 1); |
| end; |
| end if; |
| |
| return Result; |
| end Make_DT; |
| |
| --------------------------- |
| -- Make_DT_Access_Action -- |
| --------------------------- |
| |
| function Make_DT_Access_Action |
| (Typ : Entity_Id; |
| Action : DT_Access_Action; |
| Args : List_Id) return Node_Id |
| is |
| Action_Name : constant Entity_Id := RTE (Ada_Actions (Action)); |
| Loc : Source_Ptr; |
| |
| begin |
| if No (Args) then |
| |
| -- This is a constant |
| |
| return New_Reference_To (Action_Name, Sloc (Typ)); |
| end if; |
| |
| pragma Assert (List_Length (Args) = Action_Nb_Arg (Action)); |
| |
| Loc := Sloc (First (Args)); |
| |
| if Action_Is_Proc (Action) then |
| return |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Reference_To (Action_Name, Loc), |
| Parameter_Associations => Args); |
| |
| else |
| return |
| Make_Function_Call (Loc, |
| Name => New_Reference_To (Action_Name, Loc), |
| Parameter_Associations => Args); |
| end if; |
| end Make_DT_Access_Action; |
| |
| ----------------------- |
| -- Make_Secondary_DT -- |
| ----------------------- |
| |
| procedure Make_Secondary_DT |
| (Typ : Entity_Id; |
| Ancestor_Typ : Entity_Id; |
| Suffix_Index : Int; |
| Iface : Entity_Id; |
| AI_Tag : Entity_Id; |
| Acc_Disp_Tables : in out Elist_Id; |
| Result : out List_Id) |
| is |
| Loc : constant Source_Ptr := Sloc (AI_Tag); |
| Generalized_Tag : constant Entity_Id := RTE (RE_Interface_Tag); |
| Name_DT : constant Name_Id := New_Internal_Name ('T'); |
| Empty_DT : Boolean := False; |
| Iface_DT : Node_Id; |
| Iface_DT_Ptr : Node_Id; |
| Name_DT_Ptr : Name_Id; |
| Nb_Prim : Int; |
| OSD : Entity_Id; |
| Size_Expr_Node : Node_Id; |
| Tname : Name_Id; |
| |
| begin |
| Result := New_List; |
| |
| -- Generate a unique external name associated with the secondary |
| -- dispatch table. This external name will be used to declare an |
| -- access to this secondary dispatch table, value that will be used |
| -- for the elaboration of Typ's objects and also for the elaboration |
| -- of objects of any derivation of Typ that do not override any |
| -- primitive operation of Typ. |
| |
| Get_Secondary_DT_External_Name (Typ, Ancestor_Typ, Suffix_Index); |
| |
| Tname := Name_Find; |
| Name_DT_Ptr := New_External_Name (Tname, "P"); |
| Iface_DT := Make_Defining_Identifier (Loc, Name_DT); |
| Iface_DT_Ptr := Make_Defining_Identifier (Loc, Name_DT_Ptr); |
| |
| -- Dispatch table and related entities are allocated statically |
| |
| Set_Ekind (Iface_DT, E_Variable); |
| Set_Is_Statically_Allocated (Iface_DT); |
| |
| Set_Ekind (Iface_DT_Ptr, E_Variable); |
| Set_Is_Statically_Allocated (Iface_DT_Ptr); |
| |
| -- Generate code to create the storage for the Dispatch_Table object. |
| -- 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. |
| |
| Nb_Prim := UI_To_Int (DT_Entry_Count (AI_Tag)); |
| |
| if Nb_Prim = 0 then |
| Empty_DT := True; |
| Nb_Prim := 1; |
| end if; |
| |
| -- DT : Storage_Array (1..DT_Prologue_Size+nb_prim*DT_Entry_Size); |
| -- for DT'Alignment use Address'Alignment |
| |
| Size_Expr_Node := |
| Make_Op_Add (Loc, |
| Left_Opnd => Make_DT_Access_Action (Etype (AI_Tag), |
| DT_Prologue_Size, |
| No_List), |
| Right_Opnd => |
| Make_Op_Multiply (Loc, |
| Left_Opnd => |
| Make_DT_Access_Action (Etype (AI_Tag), |
| DT_Entry_Size, |
| No_List), |
| Right_Opnd => |
| Make_Integer_Literal (Loc, Nb_Prim))); |
| |
| Append_To (Result, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Iface_DT, |
| Aliased_Present => True, |
| Object_Definition => |
| Make_Subtype_Indication (Loc, |
| Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc), |
| Constraint => Make_Index_Or_Discriminant_Constraint (Loc, |
| Constraints => New_List ( |
| Make_Range (Loc, |
| Low_Bound => Make_Integer_Literal (Loc, 1), |
| High_Bound => Size_Expr_Node)))))); |
| |
| Append_To (Result, |
| Make_Attribute_Definition_Clause (Loc, |
| Name => New_Reference_To (Iface_DT, Loc), |
| Chars => Name_Alignment, |
| Expression => |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc), |
| Attribute_Name => Name_Alignment))); |
| |
| -- Generate code to create the pointer to the dispatch table |
| |
| -- Iface_DT_Ptr : Tag := Tag!(DT'Address); |
| |
| -- According to the C++ ABI, the base of the vtable is located |
| -- after the following prologue: Offset_To_Top, and Typeinfo_Ptr. |
| -- Hence, move the pointer down to the real base of the vtable. |
| |
| Append_To (Result, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Iface_DT_Ptr, |
| Constant_Present => True, |
| Object_Definition => New_Reference_To (Generalized_Tag, Loc), |
| Expression => |
| Unchecked_Convert_To (Generalized_Tag, |
| Make_Op_Add (Loc, |
| Left_Opnd => |
| Unchecked_Convert_To (RTE (RE_Storage_Offset), |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Reference_To (Iface_DT, Loc), |
| Attribute_Name => Name_Address)), |
| Right_Opnd => |
| Make_DT_Access_Action (Etype (AI_Tag), |
| DT_Prologue_Size, No_List))))); |
| |
| -- Note: Offset_To_Top will be initialized by the init subprogram |
| |
| -- Set Access_Disp_Table field to be the dispatch table pointer |
| |
| if not (Present (Acc_Disp_Tables)) then |
| Acc_Disp_Tables := New_Elmt_List; |
| end if; |
| |
| Append_Elmt (Iface_DT_Ptr, Acc_Disp_Tables); |
| |
| -- Step 1: Generate an Object Specific Data (OSD) table |
| |
| OSD := Make_Defining_Identifier (Loc, New_Internal_Name ('I')); |
| |
| -- Nothing to do if configurable run time does not support the |
| -- Object_Specific_Data entity. |
| |
| if not RTE_Available (RE_Object_Specific_Data) then |
| Error_Msg_CRT ("abstract interface types", Typ); |
| return; |
| end if; |
| |
| -- Generate: |
| -- OSD : Ada.Tags.Object_Specific_Data (Nb_Prims); |
| -- where the constraint is used to allocate space for the |
| -- non-predefined primitive operations only. |
| |
| Append_To (Result, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => OSD, |
| Object_Definition => |
| Make_Subtype_Indication (Loc, |
| Subtype_Mark => New_Reference_To ( |
| RTE (RE_Object_Specific_Data), Loc), |
| Constraint => |
| Make_Index_Or_Discriminant_Constraint (Loc, |
| Constraints => New_List ( |
| Make_Integer_Literal (Loc, Nb_Prim)))))); |
| |
| Append_To (Result, |
| Make_DT_Access_Action (Typ, |
| Action => Set_Signature, |
| Args => New_List ( |
| Unchecked_Convert_To (RTE (RE_Tag), |
| New_Reference_To (Iface_DT_Ptr, Loc)), |
| New_Reference_To (RTE (RE_Secondary_DT), Loc)))); |
| |
| -- Generate: |
| -- Ada.Tags.Set_OSD (Iface_DT_Ptr, OSD); |
| |
| Append_To (Result, |
| Make_DT_Access_Action (Typ, |
| Action => Set_OSD, |
| Args => New_List ( |
| Unchecked_Convert_To (RTE (RE_Tag), |
| New_Reference_To (Iface_DT_Ptr, Loc)), |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Reference_To (OSD, Loc), |
| Attribute_Name => Name_Address)))); |
| |
| -- Generate: |
| -- Set_Num_Prim_Ops (T'Tag, Nb_Prim) |
| |
| if RTE_Available (RE_Set_Num_Prim_Ops) then |
| if Empty_DT then |
| Append_To (Result, |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Reference_To (RTE (RE_Set_Num_Prim_Ops), Loc), |
| Parameter_Associations => New_List ( |
| Unchecked_Convert_To (RTE (RE_Tag), |
| New_Reference_To (Iface_DT_Ptr, Loc)), |
| Make_Integer_Literal (Loc, Uint_0)))); |
| else |
| Append_To (Result, |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Reference_To (RTE (RE_Set_Num_Prim_Ops), Loc), |
| Parameter_Associations => New_List ( |
| Unchecked_Convert_To (RTE (RE_Tag), |
| New_Reference_To (Iface_DT_Ptr, Loc)), |
| Make_Integer_Literal (Loc, Nb_Prim)))); |
| end if; |
| end if; |
| |
| if Ada_Version >= Ada_05 |
| and then not Is_Interface (Typ) |
| and then not Is_Abstract (Typ) |
| and then not Is_Controlled (Typ) |
| and then RTE_Available (RE_Set_Tagged_Kind) |
| and then not Restriction_Active (No_Dispatching_Calls) |
| then |
| -- Generate: |
| -- Set_Tagged_Kind (Iface'Tag, Tagged_Kind (Iface)); |
| |
| Append_To (Result, |
| Make_DT_Access_Action (Typ, |
| Action => Set_Tagged_Kind, |
| Args => New_List ( |
| Unchecked_Convert_To (RTE (RE_Tag), -- DTptr |
| New_Reference_To (Iface_DT_Ptr, Loc)), |
| Tagged_Kind (Typ)))); -- Value |
| |
| if not Empty_DT |
| and then Is_Concurrent_Record_Type (Typ) |
| and then Implements_Interface ( |
| Typ => Typ, |
| Kind => Any_Limited_Interface, |
| Check_Parent => True) |
| then |
| declare |
| Prim : Entity_Id; |
| Prim_Alias : Entity_Id; |
| Prim_Elmt : Elmt_Id; |
| |
| begin |
| -- Step 2: Populate the OSD table |
| |
| Prim_Alias := Empty; |
| Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); |
| while Present (Prim_Elmt) loop |
| Prim := Node (Prim_Elmt); |
| |
| if Present (Abstract_Interface_Alias (Prim)) then |
| Prim_Alias := Abstract_Interface_Alias (Prim); |
| end if; |
| |
| if Present (Prim_Alias) |
| and then Present (First_Entity (Prim_Alias)) |
| and then Etype (First_Entity (Prim_Alias)) = Iface |
| then |
| -- Generate: |
| -- Ada.Tags.Set_Offset_Index (Tag (Iface_DT_Ptr), |
| -- Secondary_DT_Pos, Primary_DT_pos); |
| |
| Append_To (Result, |
| Make_DT_Access_Action (Iface, |
| Action => Set_Offset_Index, |
| Args => New_List ( |
| Unchecked_Convert_To (RTE (RE_Tag), |
| New_Reference_To (Iface_DT_Ptr, Loc)), |
| Make_Integer_Literal (Loc, |
| DT_Position (Prim_Alias)), |
| Make_Integer_Literal (Loc, |
| DT_Position (Prim))))); |
| |
| Prim_Alias := Empty; |
| end if; |
| |
| Next_Elmt (Prim_Elmt); |
| end loop; |
| end; |
| end if; |
| end if; |
| end Make_Secondary_DT; |
| |
| ------------------------------------- |
| -- Make_Select_Specific_Data_Table -- |
| ------------------------------------- |
| |
| function Make_Select_Specific_Data_Table |
| (Typ : Entity_Id) return List_Id |
| is |
| Assignments : constant List_Id := New_List; |
| Loc : constant Source_Ptr := Sloc (Typ); |
| |
| Conc_Typ : Entity_Id; |
| Decls : List_Id; |
| DT_Ptr : Entity_Id; |
| Prim : Entity_Id; |
| Prim_Als : Entity_Id; |
| Prim_Elmt : Elmt_Id; |
| Prim_Pos : Uint; |
| Nb_Prim : Int := 0; |
| |
| type Examined_Array is array (Int range <>) of Boolean; |
| |
| function Find_Entry_Index (E : Entity_Id) return Uint; |
| -- Given an entry, find its index in the visible declarations of the |
| -- corresponding concurrent type of Typ. |
| |
| ---------------------- |
| -- Find_Entry_Index -- |
| ---------------------- |
| |
| function Find_Entry_Index (E : Entity_Id) return Uint is |
| Index : Uint := Uint_1; |
| Subp_Decl : Entity_Id; |
| |
| begin |
| if Present (Decls) |
| and then not Is_Empty_List (Decls) |
| then |
| Subp_Decl := First (Decls); |
| while Present (Subp_Decl) loop |
| if Nkind (Subp_Decl) = N_Entry_Declaration then |
| if Defining_Identifier (Subp_Decl) = E then |
| return Index; |
| end if; |
| |
| Index := Index + 1; |
| end if; |
| |
| Next (Subp_Decl); |
| end loop; |
| end if; |
| |
| return Uint_0; |
| end Find_Entry_Index; |
| |
| -- Start of processing for Make_Select_Specific_Data_Table |
| |
| begin |
| pragma Assert (not Restriction_Active (No_Dispatching_Calls)); |
| |
| DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); |
| |
| if Present (Corresponding_Concurrent_Type (Typ)) then |
| Conc_Typ := Corresponding_Concurrent_Type (Typ); |
| |
| if Ekind (Conc_Typ) = E_Protected_Type then |
| Decls := Visible_Declarations (Protected_Definition ( |
| Parent (Conc_Typ))); |
| else |
| pragma Assert (Ekind (Conc_Typ) = E_Task_Type); |
| Decls := Visible_Declarations (Task_Definition ( |
| Parent (Conc_Typ))); |
| end if; |
| end if; |
| |
| -- Count the non-predefined primitive operations |
| |
| Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); |
| while Present (Prim_Elmt) loop |
| if not Is_Predefined_Dispatching_Operation (Node (Prim_Elmt)) then |
| Nb_Prim := Nb_Prim + 1; |
| end if; |
| |
| Next_Elmt (Prim_Elmt); |
| end loop; |
| |
| declare |
| Examined : Examined_Array (1 .. Nb_Prim) := (others => False); |
| |
| begin |
| Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); |
| while Present (Prim_Elmt) loop |
| Prim := Node (Prim_Elmt); |
| Prim_Pos := DT_Position (Prim); |
| |
| if not Is_Predefined_Dispatching_Operation (Prim) then |
| pragma Assert (UI_To_Int (Prim_Pos) <= Nb_Prim); |
| |
| if Examined (UI_To_Int (Prim_Pos)) then |
| goto Continue; |
| else |
| Examined (UI_To_Int (Prim_Pos)) := True; |
| end if; |
| |
| -- The current primitive overrides an interface-level |
| -- subprogram |
| |
| if Present (Abstract_Interface_Alias (Prim)) then |
| |
| -- Set the primitive operation kind regardless of subprogram |
| -- type. Generate: |
| -- Ada.Tags.Set_Prim_Op_Kind (DT_Ptr, <position>, <kind>); |
| |
| Append_To (Assignments, |
| Make_DT_Access_Action (Typ, |
| Action => |
| Set_Prim_Op_Kind, |
| Args => |
| New_List ( |
| New_Reference_To (DT_Ptr, Loc), |
| Make_Integer_Literal (Loc, Prim_Pos), |
| Prim_Op_Kind (Prim, Typ)))); |
| |
| -- Retrieve the root of the alias chain if one is present |
| |
| if Present (Alias (Prim)) then |
| Prim_Als := Prim; |
| while Present (Alias (Prim_Als)) loop |
| Prim_Als := Alias (Prim_Als); |
| end loop; |
| else |
| Prim_Als := Empty; |
| end if; |
| |
| -- In the case of an entry wrapper, set the entry index |
| |
| if Ekind (Prim) = E_Procedure |
| and then Present (Prim_Als) |
| and then Is_Primitive_Wrapper (Prim_Als) |
| and then Ekind (Wrapped_Entity (Prim_Als)) = E_Entry |
| then |
| |
| -- Generate: |
| -- Ada.Tags.Set_Entry_Index |
| -- (DT_Ptr, <position>, <index>); |
| |
| Append_To (Assignments, |
| Make_DT_Access_Action (Typ, |
| Action => |
| Set_Entry_Index, |
| Args => |
| New_List ( |
| New_Reference_To (DT_Ptr, Loc), |
| Make_Integer_Literal (Loc, Prim_Pos), |
| Make_Integer_Literal (Loc, |
| Find_Entry_Index |
| (Wrapped_Entity (Prim_Als)))))); |
| end if; |
| end if; |
| end if; |
| |
| <<Continue>> |
| |
| Next_Elmt (Prim_Elmt); |
| end loop; |
| end; |
| |
| return Assignments; |
| end Make_Select_Specific_Data_Table; |
| |
| ----------------------------------- |
| -- Original_View_In_Visible_Part -- |
| ----------------------------------- |
| |
| function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean is |
| Scop : constant Entity_Id := Scope (Typ); |
| |
| begin |
| -- The scope must be a package |
| |
| if Ekind (Scop) /= E_Package |
| and then Ekind (Scop) /= E_Generic_Package |
| then |
| return False; |
| end if; |
| |
| -- A type with a private declaration has a private view declared in |
| -- the visible part. |
| |
| if Has_Private_Declaration (Typ) then |
| return True; |
| end if; |
| |
| return List_Containing (Parent (Typ)) = |
| Visible_Declarations (Specification (Unit_Declaration_Node (Scop))); |
| end Original_View_In_Visible_Part; |
| |
| ------------------ |
| -- Prim_Op_Kind -- |
| ------------------ |
| |
| function Prim_Op_Kind |
| (Prim : Entity_Id; |
| Typ : Entity_Id) return Node_Id |
| is |
| Full_Typ : Entity_Id := Typ; |
| Loc : constant Source_Ptr := Sloc (Prim); |
| Prim_Op : Entity_Id; |
| |
| begin |
| -- Retrieve the original primitive operation |
| |
| Prim_Op := Prim; |
| while Present (Alias (Prim_Op)) loop |
| Prim_Op := Alias (Prim_Op); |
| end loop; |
| |
| if Ekind (Typ) = E_Record_Type |
| and then Present (Corresponding_Concurrent_Type (Typ)) |
| then |
| Full_Typ := Corresponding_Concurrent_Type (Typ); |
| end if; |
| |
| if Ekind (Prim_Op) = E_Function then |
| |
| -- Protected function |
| |
| if Ekind (Full_Typ) = E_Protected_Type then |
| return New_Reference_To (RTE (RE_POK_Protected_Function), Loc); |
| |
| -- Task function |
| |
| elsif Ekind (Full_Typ) = E_Task_Type then |
| return New_Reference_To (RTE (RE_POK_Task_Function), Loc); |
| |
| -- Regular function |
| |
| else |
| return New_Reference_To (RTE (RE_POK_Function), Loc); |
| end if; |
| |
| else |
| pragma Assert (Ekind (Prim_Op) = E_Procedure); |
| |
| if Ekind (Full_Typ) = E_Protected_Type then |
| |
| -- Protected entry |
| |
| if Is_Primitive_Wrapper (Prim_Op) |
| and then Ekind (Wrapped_Entity (Prim_Op)) = E_Entry |
| then |
| return New_Reference_To (RTE (RE_POK_Protected_Entry), Loc); |
| |
| -- Protected procedure |
| |
| else |
| return New_Reference_To (RTE (RE_POK_Protected_Procedure), Loc); |
| end if; |
| |
| elsif Ekind (Full_Typ) = E_Task_Type then |
| |
| -- Task entry |
| |
| if Is_Primitive_Wrapper (Prim_Op) |
| and then Ekind (Wrapped_Entity (Prim_Op)) = E_Entry |
| then |
| return New_Reference_To (RTE (RE_POK_Task_Entry), Loc); |
| |
| -- Task "procedure". These are the internally Expander-generated |
| -- procedures (task body for instance). |
| |
| else |
| return New_Reference_To (RTE (RE_POK_Task_Procedure), Loc); |
| end if; |
| |
| -- Regular procedure |
| |
| else |
| return New_Reference_To (RTE (RE_POK_Procedure), Loc); |
| end if; |
| end if; |
| end Prim_Op_Kind; |
| |
| ------------------------- |
| -- Set_All_DT_Position -- |
| ------------------------- |
| |
| procedure Set_All_DT_Position (Typ : Entity_Id) is |
| Parent_Typ : constant Entity_Id := Etype (Typ); |
| Root_Typ : constant Entity_Id := Root_Type (Typ); |
| First_Prim : constant Elmt_Id := First_Elmt (Primitive_Operations (Typ)); |
| The_Tag : constant Entity_Id := First_Tag_Component (Typ); |
| |
| Adjusted : Boolean := False; |
| Finalized : Boolean := False; |
| |
| Count_Prim : Int; |
| DT_Length : Int; |
| Nb_Prim : Int; |
| Parent_EC : Int; |
| Prim : Entity_Id; |
| Prim_Elmt : Elmt_Id; |
| |
| procedure Validate_Position (Prim : Entity_Id); |
| -- Check that the position assignated to Prim is completely safe |
| -- (it has not been assigned to a previously defined primitive |
| -- operation of Typ) |
| |
| ----------------------- |
| -- Validate_Position -- |
| ----------------------- |
| |
| procedure Validate_Position (Prim : Entity_Id) is |
| Prim_Elmt : Elmt_Id; |
| |
| begin |
| Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); |
| while Present (Prim_Elmt) |
| and then Node (Prim_Elmt) /= Prim |
| loop |
| -- Primitive operations covering abstract interfaces are |
| -- allocated later |
| |
| if Present (Abstract_Interface_Alias (Node (Prim_Elmt))) then |
| null; |
| |
| -- Predefined dispatching operations are completely safe. They |
| -- are allocated at fixed positions in a separate table. |
| |
| elsif Is_Predefined_Dispatching_Operation (Node (Prim_Elmt)) then |
| null; |
| |
| -- Aliased subprograms are safe |
| |
| elsif Present (Alias (Prim)) then |
| null; |
| |
| elsif DT_Position (Node (Prim_Elmt)) = DT_Position (Prim) then |
| |
| -- Handle aliased subprograms |
| |
| declare |
| Op_1 : Entity_Id; |
| Op_2 : Entity_Id; |
| |
| begin |
| Op_1 := Node (Prim_Elmt); |
| loop |
| if Present (Overridden_Operation (Op_1)) then |
| Op_1 := Overridden_Operation (Op_1); |
| elsif Present (Alias (Op_1)) then |
| Op_1 := Alias (Op_1); |
| else |
| exit; |
| end if; |
| end loop; |
| |
| Op_2 := Prim; |
| loop |
| if Present (Overridden_Operation (Op_2)) then |
| Op_2 := Overridden_Operation (Op_2); |
| elsif Present (Alias (Op_2)) then |
| Op_2 := Alias (Op_2); |
| else |
| exit; |
| end if; |
| end loop; |
| |
| if Op_1 /= Op_2 then |
| raise Program_Error; |
| end if; |
| end; |
| end if; |
| |
| Next_Elmt (Prim_Elmt); |
| end loop; |
| end Validate_Position; |
| |
| -- Start of processing for Set_All_DT_Position |
| |
| begin |
| -- Get Entry_Count of the parent |
| |
| if Parent_Typ /= Typ |
| and then DT_Entry_Count (First_Tag_Component (Parent_Typ)) /= No_Uint |
| then |
| Parent_EC := UI_To_Int (DT_Entry_Count |
| (First_Tag_Component (Parent_Typ))); |
| else |
| Parent_EC := 0; |
| end if; |
| |
| -- C++ Case, check that pragma CPP_Class, CPP_Virtual and CPP_Vtable |
| -- give a coherent set of information |
| |
| if Is_CPP_Class (Root_Typ) then |
| |
| -- Compute the number of primitive operations in the main Vtable |
| -- Set their position: |
| -- - where it was set if overriden or inherited |
| -- - after the end of the parent vtable otherwise |
| |
| Prim_Elmt := First_Prim; |
| Nb_Prim := 0; |
| while Present (Prim_Elmt) loop |
| Prim := Node (Prim_Elmt); |
| |
| if not Is_CPP_Class (Typ) then |
| Set_DTC_Entity (Prim, The_Tag); |
| |
| elsif Present (Alias (Prim)) then |
| Set_DTC_Entity (Prim, DTC_Entity (Alias (Prim))); |
| Set_DT_Position (Prim, DT_Position (Alias (Prim))); |
| |
| elsif No (DTC_Entity (Prim)) and then Is_CPP_Class (Typ) then |
| Error_Msg_NE ("is a primitive operation of&," & |
| " pragma Cpp_Virtual required", Prim, Typ); |
| end if; |
| |
| if DTC_Entity (Prim) = The_Tag then |
| |
| -- Get the slot from the parent subprogram if any |
| |
| declare |
| H : Entity_Id; |
| |
| begin |
| H := Homonym (Prim); |
| while Present (H) loop |
| if Present (DTC_Entity (H)) |
| and then Root_Type (Scope (DTC_Entity (H))) = Root_Typ |
| then |
| Set_DT_Position (Prim, DT_Position (H)); |
| exit; |
| end if; |
| |
| H := Homonym (H); |
| end loop; |
| end; |
| |
| -- Otherwise take the canonical slot after the end of the |
| -- parent Vtable |
| |
| if DT_Position (Prim) = No_Uint then |
| Nb_Prim := Nb_Prim + 1; |
| Set_DT_Position (Prim, UI_From_Int (Parent_EC + Nb_Prim)); |
| |
| elsif UI_To_Int (DT_Position (Prim)) > Parent_EC then |
| Nb_Prim := Nb_Prim + 1; |
| end if; |
| end if; |
| |
| Next_Elmt (Prim_Elmt); |
| end loop; |
| |
| -- Check that the declared size of the Vtable is bigger or equal |
| -- than the number of primitive operations (if bigger it means that |
| -- some of the c++ virtual functions were not imported, that is |
| -- allowed). |
| |
| if DT_Entry_Count (The_Tag) = No_Uint |
| or else not Is_CPP_Class (Typ) |
| then |
| Set_DT_Entry_Count (The_Tag, UI_From_Int (Parent_EC + Nb_Prim)); |
| |
| elsif UI_To_Int (DT_Entry_Count (The_Tag)) < Parent_EC + Nb_Prim then |
| Error_Msg_N ("not enough room in the Vtable for all virtual" |
| & " functions", The_Tag); |
| end if; |
| |
| -- Check that Positions are not duplicate nor outside the range of |
| -- the Vtable. |
| |
| declare |
| Size : constant Int := UI_To_Int (DT_Entry_Count (The_Tag)); |
| Pos : Int; |
| Prim_Pos_Table : array (1 .. Size) of Entity_Id := |
| (others => Empty); |
| |
| begin |
| Prim_Elmt := First_Prim; |
| while Present (Prim_Elmt) loop |
| Prim := Node (Prim_Elmt); |
| |
| if DTC_Entity (Prim) = The_Tag then |
| Pos := UI_To_Int (DT_Position (Prim)); |
| |
| if Pos not in Prim_Pos_Table'Range then |
| Error_Msg_N |
| ("position not in range of virtual table", Prim); |
| |
| elsif Present (Prim_Pos_Table (Pos)) then |
| Error_Msg_NE ("cannot be at the same position in the" |
| & " vtable than&", Prim, Prim_Pos_Table (Pos)); |
| |
| else |
| Prim_Pos_Table (Pos) := Prim; |
| end if; |
| end if; |
| |
| Next_Elmt (Prim_Elmt); |
| end loop; |
| end; |
| |
| -- Generate listing showing the contents of the dispatch tables |
| |
| if Debug_Flag_ZZ then |
| Write_DT (Typ); |
| end if; |
| |
| -- For regular Ada tagged types, just set the DT_Position for |
| -- each primitive operation. Perform some sanity checks to avoid |
| -- to build completely inconsistant dispatch tables. |
| |
| -- Note that the _Size primitive is always set at position 1 in order |
| -- to comply with the needs of Ada.Tags.Parent_Size (see documentation |
| -- in Ada.Tags). |
| |
| else |
| -- First stage: Set the DTC entity of all the primitive operations |
| -- This is required to properly read the DT_Position attribute in |
| -- the latter stages. |
| |
| Prim_Elmt := First_Prim; |
| Count_Prim := 0; |
| while Present (Prim_Elmt) loop |
| Count_Prim := Count_Prim + 1; |
| Prim := Node (Prim_Elmt); |
| |
| -- Ada 2005 (AI-251) |
| |
| if Present (Abstract_Interface_Alias (Prim)) |
| and then Is_Interface (Scope (DTC_Entity |
| (Abstract_Interface_Alias (Prim)))) |
| then |
| Set_DTC_Entity (Prim, |
| Find_Interface_Tag |
| (T => Typ, |
| Iface => Scope (DTC_Entity |
| (Abstract_Interface_Alias (Prim))))); |
| |
| else |
| Set_DTC_Entity (Prim, The_Tag); |
| end if; |
| |
| -- Clear any previous value of the DT_Position attribute. In this |
| -- way we ensure that the final position of all the primitives is |
| -- stablished by the following stages of this algorithm. |
| |
| Set_DT_Position (Prim, No_Uint); |
| |
| Next_Elmt (Prim_Elmt); |
| end loop; |
| |
| declare |
| Fixed_Prim : array (Int range 0 .. Parent_EC + Count_Prim) |
| of Boolean := (others => False); |
| |
| E : Entity_Id; |
| |
| begin |
| -- Second stage: Register fixed entries |
| |
| Nb_Prim := 0; |
| Prim_Elmt := First_Prim; |
| while Present (Prim_Elmt) loop |
| Prim := Node (Prim_Elmt); |
| |
| -- Predefined primitives have a separate table and all its |
| -- entries are at predefined fixed positions |
| |
| if Is_Predefined_Dispatching_Operation (Prim) then |
| Set_DT_Position (Prim, Default_Prim_Op_Position (Prim)); |
| |
| -- Overriding interface primitives of an ancestor |
| |
| elsif DT_Position (Prim) = No_Uint |
| and then Present (Abstract_Interface_Alias (Prim)) |
| and then Present (DTC_Entity |
| (Abstract_Interface_Alias (Prim))) |
| and then DT_Position (Abstract_Interface_Alias (Prim)) |
| /= No_Uint |
| and then Is_Inherited_Operation (Prim) |
| and then Is_Ancestor (Scope |
| (DTC_Entity |
| (Abstract_Interface_Alias (Prim))), |
| Typ) |
| then |
| Set_DT_Position (Prim, |
| DT_Position (Abstract_Interface_Alias (Prim))); |
| Set_DT_Position (Alias (Prim), |
| DT_Position (Abstract_Interface_Alias (Prim))); |
| Fixed_Prim (UI_To_Int (DT_Position (Prim))) := True; |
| |
| -- Overriding primitives must use the same entry as the |
| -- overriden primitive |
| |
| elsif DT_Position (Prim) = No_Uint |
| and then Present (Alias (Prim)) |
| and then Present (DTC_Entity (Alias (Prim))) |
| and then DT_Position (Alias (Prim)) /= No_Uint |
| and then Is_Inherited_Operation (Prim) |
| and then Is_Ancestor (Scope (DTC_Entity (Alias (Prim))), Typ) |
| then |
| E := Alias (Prim); |
| while not (Present (DTC_Entity (E)) |
| or else DT_Position (E) = No_Uint) |
| and then Present (Alias (E)) |
| loop |
| E := Alias (E); |
| end loop; |
| |
| pragma Assert (Present (DTC_Entity (E)) |
| and then |
| DT_Position (E) /= No_Uint); |
| |
| Set_DT_Position (Prim, DT_Position (E)); |
| Fixed_Prim (UI_To_Int (DT_Position (E))) := True; |
| |
| -- If this is not the last element in the chain continue |
| -- traversing the chain. This is required to properly |
| -- handling renamed primitives |
| |
| while Present (Alias (E)) loop |
| E := Alias (E); |
| Fixed_Prim (UI_To_Int (DT_Position (E))) := True; |
| end loop; |
| end if; |
| |
| Next_Elmt (Prim_Elmt); |
| end loop; |
| |
| -- Third stage: Fix the position of all the new primitives |
| -- Entries associated with primitives covering interfaces |
| -- are handled in a latter round. |
| |
| Prim_Elmt := First_Prim; |
| while Present (Prim_Elmt) loop |
| Prim := Node (Prim_Elmt); |
| |
| -- Skip primitives previously set entries |
| |
| if Is_Predefined_Dispatching_Operation (Prim) then |
| null; |
| |
| elsif DT_Position (Prim) /= No_Uint then |
| null; |
| |
| elsif Etype (DTC_Entity (Prim)) /= RTE (RE_Tag) then |
| null; |
| |
| -- Primitives covering interface primitives are |
| -- handled later |
| |
| elsif Present (Abstract_Interface_Alias (Prim)) then |
| null; |
| |
| else |
| -- Take the next available position in the DT |
| |
| loop |
| Nb_Prim := Nb_Prim + 1; |
| exit when not Fixed_Prim (Nb_Prim); |
| end loop; |
| |
| Set_DT_Position (Prim, UI_From_Int (Nb_Prim)); |
| Fixed_Prim (Nb_Prim) := True; |
| end if; |
| |
| Next_Elmt (Prim_Elmt); |
| end loop; |
| end; |
| |
| -- Fourth stage: Complete the decoration of primitives covering |
| -- interfaces (that is, propagate the DT_Position attribute |
| -- from the aliased primitive) |
| |
| Prim_Elmt := First_Prim; |
| while Present (Prim_Elmt) loop |
| Prim := Node (Prim_Elmt); |
| |
| if DT_Position (Prim) = No_Uint |
| and then Present (Abstract_Interface_Alias (Prim)) |
| then |
| -- Check if this entry will be placed in the primary DT |
| |
| if Etype (DTC_Entity (Abstract_Interface_Alias (Prim))) |
| = RTE (RE_Tag) |
| then |
| pragma Assert (DT_Position (Alias (Prim)) /= No_Uint); |
| Set_DT_Position (Prim, DT_Position (Alias (Prim))); |
| |
| -- Otherwise it will be placed in the secondary DT |
| |
| else |
| pragma Assert |
| (DT_Position (Abstract_Interface_Alias (Prim)) /= No_Uint); |
| |
| Set_DT_Position (Prim, |
| DT_Position (Abstract_Interface_Alias (Prim))); |
| end if; |
| end if; |
| |
| Next_Elmt (Prim_Elmt); |
| end loop; |
| |
| -- Generate listing showing the contents of the dispatch tables. |
| -- This action is done before some further static checks because |
| -- in case of critical errors caused by a wrong dispatch table |
| -- we need to see the contents of such table. |
| |
| if Debug_Flag_ZZ then |
| Write_DT (Typ); |
| end if; |
| |
| -- Final stage: Ensure that the table is correct plus some further |
| -- verifications concerning the primitives. |
| |
| Prim_Elmt := First_Prim; |
| DT_Length := 0; |
| while Present (Prim_Elmt) loop |
| Prim := Node (Prim_Elmt); |
| |
| -- At this point all the primitives MUST have a position |
| -- in the dispatch table |
| |
| if DT_Position (Prim) = No_Uint then |
| raise Program_Error; |
| end if; |
| |
| -- Calculate real size of the dispatch table |
| |
| if not Is_Predefined_Dispatching_Operation (Prim) |
| and then UI_To_Int (DT_Position (Prim)) > DT_Length |
| then |
| DT_Length := UI_To_Int (DT_Position (Prim)); |
| end if; |
| |
| -- Ensure that the asignated position to non-predefined |
| -- dispatching operations in the dispatch table is correct. |
| |
| if not Is_Predefined_Dispatching_Operation (Prim) then |
| Validate_Position (Prim); |
| end if; |
| |
| if Chars (Prim) = Name_Finalize then |
| Finalized := True; |
| end if; |
| |
| if Chars (Prim) = Name_Adjust then |
| Adjusted := True; |
| end if; |
| |
| -- An abstract operation cannot be declared in the private part |
| -- for a visible abstract type, because it could never be over- |
| -- ridden. For explicit declarations this is checked at the |
| -- point of declaration, but for inherited operations it must |
| -- be done when building the dispatch table. Input is excluded |
| -- because |
| |
| if Is_Abstract (Typ) |
| and then Is_Abstract (Prim) |
| and then Present (Alias (Prim)) |
| and then Is_Derived_Type (Typ) |
| and then In_Private_Part (Current_Scope) |
| and then |
| List_Containing (Parent (Prim)) = |
| Private_Declarations |
| (Specification (Unit_Declaration_Node (Current_Scope))) |
| and then Original_View_In_Visible_Part (Typ) |
| then |
| -- We exclude Input and Output stream operations because |
| -- Limited_Controlled inherits useless Input and Output |
| -- stream operations from Root_Controlled, which can |
| -- never be overridden. |
| |
| if not Is_TSS (Prim, TSS_Stream_Input) |
| and then |
| not Is_TSS (Prim, TSS_Stream_Output) |
| then |
| Error_Msg_NE |
| ("abstract inherited private operation&" & |
| " must be overridden ('R'M 3.9.3(10))", |
| Parent (Typ), Prim); |
| end if; |
| end if; |
| |
| Next_Elmt (Prim_Elmt); |
| end loop; |
| |
| -- Additional check |
| |
| if Is_Controlled (Typ) then |
| if not Finalized then |
| Error_Msg_N |
| ("controlled type has no explicit Finalize method?", Typ); |
| |
| elsif not Adjusted then |
| Error_Msg_N |
| ("controlled type has no explicit Adjust method?", Typ); |
| end if; |
| end if; |
| |
| -- Set the final size of the Dispatch Table |
| |
| Set_DT_Entry_Count (The_Tag, UI_From_Int (DT_Length)); |
| |
| -- The derived type must have at least as many components as its |
| -- parent (for root types, the Etype points back to itself |
| -- and the test should not fail) |
| |
| -- This test fails compiling the partial view of a tagged type |
| -- derived from an interface which defines the overriding subprogram |
| -- in the private part. This needs further investigation??? |
| |
| if not Has_Private_Declaration (Typ) then |
| pragma Assert ( |
| DT_Entry_Count (The_Tag) >= |
| DT_Entry_Count (First_Tag_Component (Parent_Typ))); |
| null; |
| end if; |
| end if; |
| end Set_All_DT_Position; |
| |
| ----------------------------- |
| -- Set_Default_Constructor -- |
| ----------------------------- |
| |
| procedure Set_Default_Constructor (Typ : Entity_Id) is |
| Loc : Source_Ptr; |
| Init : Entity_Id; |
| Param : Entity_Id; |
| E : Entity_Id; |
| |
| begin |
| -- Look for the default constructor entity. For now only the |
| -- default constructor has the flag Is_Constructor. |
| |
| E := Next_Entity (Typ); |
| while Present (E) |
| and then (Ekind (E) /= E_Function or else not Is_Constructor (E)) |
| loop |
| Next_Entity (E); |
| end loop; |
| |
| -- Create the init procedure |
| |
| if Present (E) then |
| Loc := Sloc (E); |
| Init := Make_Defining_Identifier (Loc, Make_Init_Proc_Name (Typ)); |
| Param := Make_Defining_Identifier (Loc, Name_X); |
| |
| Discard_Node ( |
| Make_Subprogram_Declaration (Loc, |
| Make_Procedure_Specification (Loc, |
| Defining_Unit_Name => Init, |
| Parameter_Specifications => New_List ( |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Param, |
| Parameter_Type => New_Reference_To (Typ, Loc)))))); |
| |
| Set_Init_Proc (Typ, Init); |
| Set_Is_Imported (Init); |
| Set_Interface_Name (Init, Interface_Name (E)); |
| Set_Convention (Init, Convention_C); |
| Set_Is_Public (Init); |
| Set_Has_Completion (Init); |
| |
| -- If there are no constructors, mark the type as abstract since we |
| -- won't be able to declare objects of that type. |
| |
| else |
| Set_Is_Abstract (Typ); |
| end if; |
| end Set_Default_Constructor; |
| |
| ----------------- |
| -- Tagged_Kind -- |
| ----------------- |
| |
| function Tagged_Kind (T : Entity_Id) return Node_Id is |
| Conc_Typ : Entity_Id; |
| Loc : constant Source_Ptr := Sloc (T); |
| |
| begin |
| pragma Assert |
| (Is_Tagged_Type (T) and then RTE_Available (RE_Tagged_Kind)); |
| |
| -- Abstract kinds |
| |
| if Is_Abstract (T) then |
| if Is_Limited_Record (T) then |
| return New_Reference_To (RTE (RE_TK_Abstract_Limited_Tagged), Loc); |
| else |
| return New_Reference_To (RTE (RE_TK_Abstract_Tagged), Loc); |
| end if; |
| |
| -- Concurrent kinds |
| |
| elsif Is_Concurrent_Record_Type (T) then |
| Conc_Typ := Corresponding_Concurrent_Type (T); |
| |
| if Ekind (Conc_Typ) = E_Protected_Type then |
| return New_Reference_To (RTE (RE_TK_Protected), Loc); |
| else |
| pragma Assert (Ekind (Conc_Typ) = E_Task_Type); |
| return New_Reference_To (RTE (RE_TK_Task), Loc); |
| end if; |
| |
| -- Regular tagged kinds |
| |
| else |
| if Is_Limited_Record (T) then |
| return New_Reference_To (RTE (RE_TK_Limited_Tagged), Loc); |
| else |
| return New_Reference_To (RTE (RE_TK_Tagged), Loc); |
| end if; |
| end if; |
| end Tagged_Kind; |
| |
| -------------- |
| -- Write_DT -- |
| -------------- |
| |
| procedure Write_DT (Typ : Entity_Id) is |
| Elmt : Elmt_Id; |
| Prim : Node_Id; |
| |
| begin |
| -- Protect this procedure against wrong usage. Required because it will |
| -- be used directly from GDB |
| |
| -- LLVM local |
| if not (Typ <= Last_Node_Id) |
| or else not Is_Tagged_Type (Typ) |
| then |
| Write_Str ("wrong usage: Write_DT must be used with tagged types"); |
| Write_Eol; |
| return; |
| end if; |
| |
| Write_Int (Int (Typ)); |
| Write_Str (": "); |
| Write_Name (Chars (Typ)); |
| |
| if Is_Interface (Typ) then |
| Write_Str (" is interface"); |
| end if; |
| |
| Write_Eol; |
| |
| Elmt := First_Elmt (Primitive_Operations (Typ)); |
| while Present (Elmt) loop |
| Prim := Node (Elmt); |
| Write_Str (" - "); |
| |
| -- Indicate if this primitive will be allocated in the primary |
| -- dispatch table or in a secondary dispatch table associated |
| -- with an abstract interface type |
| |
| if Present (DTC_Entity (Prim)) then |
| if Etype (DTC_Entity (Prim)) = RTE (RE_Tag) then |
| Write_Str ("[P] "); |
| else |
| Write_Str ("[s] "); |
| end if; |
| end if; |
| |
| -- Output the node of this primitive operation and its name |
| |
| Write_Int (Int (Prim)); |
| Write_Str (": "); |
| |
| if Is_Predefined_Dispatching_Operation (Prim) then |
| Write_Str ("(predefined) "); |
| end if; |
| |
| Write_Name (Chars (Prim)); |
| |
| -- Indicate if this primitive has an aliased primitive |
| |
| if Present (Alias (Prim)) then |
| Write_Str (" (alias = "); |
| Write_Int (Int (Alias (Prim))); |
| |
| -- If the DTC_Entity attribute is already set we can also output |
| -- the name of the interface covered by this primitive (if any) |
| |
| if Present (DTC_Entity (Alias (Prim))) |
| and then Is_Interface (Scope (DTC_Entity (Alias (Prim)))) |
| then |
| Write_Str (" from interface "); |
| Write_Name (Chars (Scope (DTC_Entity (Alias (Prim))))); |
| end if; |
| |
| if Present (Abstract_Interface_Alias (Prim)) then |
| Write_Str (", AI_Alias of "); |
| Write_Name (Chars (Scope (DTC_Entity |
| (Abstract_Interface_Alias (Prim))))); |
| Write_Char (':'); |
| Write_Int (Int (Abstract_Interface_Alias (Prim))); |
| end if; |
| |
| Write_Str (")"); |
| end if; |
| |
| -- Display the final position of this primitive in its associated |
| -- (primary or secondary) dispatch table |
| |
| if Present (DTC_Entity (Prim)) |
| and then DT_Position (Prim) /= No_Uint |
| then |
| Write_Str (" at #"); |
| Write_Int (UI_To_Int (DT_Position (Prim))); |
| end if; |
| |
| if Is_Abstract (Prim) then |
| Write_Str (" is abstract;"); |
| end if; |
| |
| Write_Eol; |
| |
| Next_Elmt (Elmt); |
| end loop; |
| end Write_DT; |
| |
| end Exp_Disp; |