| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- E X P _ D I S P -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- |
| -- -- |
| -- GNAT is free software; you can redistribute it and/or modify it under -- |
| -- terms of the GNU General Public License as published by the Free Soft- -- |
| -- ware Foundation; either version 3, or (at your option) any later ver- -- |
| -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- |
| -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- |
| -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- |
| -- for more details. You should have received a copy of the GNU General -- |
| -- Public License distributed with GNAT; see file COPYING3. If not, go to -- |
| -- http://www.gnu.org/licenses for a complete copy of the license. -- |
| -- -- |
| -- GNAT was originally developed by the GNAT team at New York University. -- |
| -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| |
| with Atree; use Atree; |
| with Checks; use Checks; |
| with Debug; use Debug; |
| with Einfo; use Einfo; |
| with Elists; use Elists; |
| with Errout; use Errout; |
| with Exp_Atag; use Exp_Atag; |
| 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 Freeze; use Freeze; |
| 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_Ch6; use Sem_Ch6; |
| with Sem_Ch8; use Sem_Ch8; |
| with Sem_Disp; use Sem_Disp; |
| with Sem_Eval; use Sem_Eval; |
| with Sem_Res; use Sem_Res; |
| with Sem_Type; use Sem_Type; |
| with Sem_Util; use Sem_Util; |
| with Sinfo; use Sinfo; |
| with Snames; use Snames; |
| with Stand; use Stand; |
| with Stringt; use Stringt; |
| with Targparm; use Targparm; |
| with Tbuild; use Tbuild; |
| with Uintp; use Uintp; |
| |
| package body Exp_Disp is |
| |
| ----------------------- |
| -- Local Subprograms -- |
| ----------------------- |
| |
| function Default_Prim_Op_Position (E : Entity_Id) return Uint; |
| -- Ada 2005 (AI-251): Returns the fixed position in the dispatch table |
| -- of the default primitive operations. |
| |
| function Has_DT (Typ : Entity_Id) return Boolean; |
| pragma Inline (Has_DT); |
| -- Returns true if we generate a dispatch table for tagged type Typ |
| |
| function Is_Predefined_Dispatching_Alias (Prim : Entity_Id) return Boolean; |
| -- Returns true if Prim is not a predefined dispatching primitive but it is |
| -- an alias of a predefined dispatching primitive (ie. through a renaming) |
| |
| 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. |
| |
| ------------------------ |
| -- Building_Static_DT -- |
| ------------------------ |
| |
| function Building_Static_DT (Typ : Entity_Id) return Boolean is |
| begin |
| return Static_Dispatch_Tables |
| and then Is_Library_Level_Tagged_Type (Typ) |
| |
| -- If the type is derived from a CPP class we cannot statically |
| -- build the dispatch tables because we must inherit primitives |
| -- from the CPP side. |
| |
| and then not Is_CPP_Class (Root_Type (Typ)); |
| end Building_Static_DT; |
| |
| ---------------------------------- |
| -- Build_Static_Dispatch_Tables -- |
| ---------------------------------- |
| |
| procedure Build_Static_Dispatch_Tables (N : Entity_Id) is |
| Target_List : List_Id; |
| |
| procedure Build_Dispatch_Tables (List : List_Id); |
| -- Build the static dispatch table of tagged types found in the list of |
| -- declarations. The generated nodes are added at the end of Target_List |
| |
| procedure Build_Package_Dispatch_Tables (N : Node_Id); |
| -- Build static dispatch tables associated with package declaration N |
| |
| --------------------------- |
| -- Build_Dispatch_Tables -- |
| --------------------------- |
| |
| procedure Build_Dispatch_Tables (List : List_Id) is |
| D : Node_Id; |
| |
| begin |
| D := First (List); |
| while Present (D) loop |
| |
| -- Handle nested packages and package bodies recursively. The |
| -- generated code is placed on the Target_List established for |
| -- the enclosing compilation unit. |
| |
| if Nkind (D) = N_Package_Declaration then |
| Build_Package_Dispatch_Tables (D); |
| |
| elsif Nkind (D) = N_Package_Body then |
| Build_Dispatch_Tables (Declarations (D)); |
| |
| elsif Nkind (D) = N_Package_Body_Stub |
| and then Present (Library_Unit (D)) |
| then |
| Build_Dispatch_Tables |
| (Declarations (Proper_Body (Unit (Library_Unit (D))))); |
| |
| -- Handle full type declarations and derivations of library |
| -- level tagged types |
| |
| elsif (Nkind (D) = N_Full_Type_Declaration |
| or else Nkind (D) = N_Derived_Type_Definition) |
| and then Is_Library_Level_Tagged_Type (Defining_Entity (D)) |
| and then Ekind (Defining_Entity (D)) /= E_Record_Subtype |
| and then not Is_Private_Type (Defining_Entity (D)) |
| then |
| Insert_List_After_And_Analyze (Last (Target_List), |
| Make_DT (Defining_Entity (D))); |
| |
| -- Handle private types of library level tagged types. We must |
| -- exchange the private and full-view to ensure the correct |
| -- expansion. |
| |
| elsif (Nkind (D) = N_Private_Type_Declaration |
| or else Nkind (D) = N_Private_Extension_Declaration) |
| and then Present (Full_View (Defining_Entity (D))) |
| and then Is_Library_Level_Tagged_Type |
| (Full_View (Defining_Entity (D))) |
| and then Ekind (Full_View (Defining_Entity (D))) |
| /= E_Record_Subtype |
| then |
| declare |
| E1, E2 : Entity_Id; |
| begin |
| E1 := Defining_Entity (D); |
| E2 := Full_View (Defining_Entity (D)); |
| Exchange_Entities (E1, E2); |
| Insert_List_After_And_Analyze (Last (Target_List), |
| Make_DT (E1)); |
| Exchange_Entities (E1, E2); |
| end; |
| end if; |
| |
| Next (D); |
| end loop; |
| end Build_Dispatch_Tables; |
| |
| ----------------------------------- |
| -- Build_Package_Dispatch_Tables -- |
| ----------------------------------- |
| |
| procedure Build_Package_Dispatch_Tables (N : Node_Id) is |
| Spec : constant Node_Id := Specification (N); |
| Id : constant Entity_Id := Defining_Entity (N); |
| Vis_Decls : constant List_Id := Visible_Declarations (Spec); |
| Priv_Decls : constant List_Id := Private_Declarations (Spec); |
| |
| begin |
| Push_Scope (Id); |
| |
| if Present (Priv_Decls) then |
| Build_Dispatch_Tables (Vis_Decls); |
| Build_Dispatch_Tables (Priv_Decls); |
| |
| elsif Present (Vis_Decls) then |
| Build_Dispatch_Tables (Vis_Decls); |
| end if; |
| |
| Pop_Scope; |
| end Build_Package_Dispatch_Tables; |
| |
| -- Start of processing for Build_Static_Dispatch_Tables |
| |
| begin |
| if not Expander_Active |
| or else VM_Target /= No_VM |
| then |
| return; |
| end if; |
| |
| if Nkind (N) = N_Package_Declaration then |
| declare |
| Spec : constant Node_Id := Specification (N); |
| Vis_Decls : constant List_Id := Visible_Declarations (Spec); |
| Priv_Decls : constant List_Id := Private_Declarations (Spec); |
| |
| begin |
| if Present (Priv_Decls) |
| and then Is_Non_Empty_List (Priv_Decls) |
| then |
| Target_List := Priv_Decls; |
| |
| elsif not Present (Vis_Decls) then |
| Target_List := New_List; |
| Set_Private_Declarations (Spec, Target_List); |
| else |
| Target_List := Vis_Decls; |
| end if; |
| |
| Build_Package_Dispatch_Tables (N); |
| end; |
| |
| else pragma Assert (Nkind (N) = N_Package_Body); |
| Target_List := Declarations (N); |
| Build_Dispatch_Tables (Target_List); |
| end if; |
| end Build_Static_Dispatch_Tables; |
| |
| ------------------------------ |
| -- 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_Requeue then |
| return Uint_15; |
| |
| elsif Chars (E) = Name_uDisp_Timed_Select then |
| return Uint_16; |
| end if; |
| end if; |
| |
| raise Program_Error; |
| end Default_Prim_Op_Position; |
| |
| ----------------------------- |
| -- 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; |
| CW_Typ : Entity_Id; |
| New_Call : Node_Id; |
| New_Call_Name : Node_Id; |
| New_Params : List_Id := No_List; |
| Param : Node_Id; |
| Res_Typ : Entity_Id; |
| Subp_Ptr_Typ : Entity_Id; |
| Subp_Typ : Entity_Id; |
| Typ : Entity_Id; |
| Eq_Prim_Op : Entity_Id := Empty; |
| Controlling_Tag : Node_Id; |
| |
| function New_Value (From : Node_Id) return Node_Id; |
| -- From is the original Expression. New_Value is equivalent to a call |
| -- to Duplicate_Subexpr with an explicit dereference when From is an |
| -- access parameter. |
| |
| --------------- |
| -- New_Value -- |
| --------------- |
| |
| function New_Value (From : Node_Id) return Node_Id is |
| Res : constant Node_Id := Duplicate_Subexpr (From); |
| begin |
| if Is_Access_Type (Etype (From)) then |
| return |
| Make_Explicit_Dereference (Sloc (From), |
| Prefix => Res); |
| else |
| return Res; |
| end if; |
| end New_Value; |
| |
| -- Start of processing for Expand_Dispatching_Call |
| |
| begin |
| if No_Run_Time_Mode then |
| Error_Msg_CRT ("tagged types", Call_Node); |
| return; |
| end if; |
| |
| -- Expand_Dispatching_Call is called directly from the semantics, |
| -- so we need a check to see whether expansion is active before |
| -- proceeding. In addition, there is no need to expand the call |
| -- if we are compiling under restriction No_Dispatching_Calls; |
| -- the semantic analyzer has previously notified the violation |
| -- of this restriction. |
| |
| if not Expander_Active |
| or else Restriction_Active (No_Dispatching_Calls) |
| then |
| return; |
| end if; |
| |
| -- Set subprogram. If this is an inherited operation that was |
| -- overridden, the body that is being called is its alias. |
| |
| Subp := Entity (Name (Call_Node)); |
| |
| if Present (Alias (Subp)) |
| and then Is_Inherited_Operation (Subp) |
| and then No (DTC_Entity (Subp)) |
| then |
| Subp := Alias (Subp); |
| end if; |
| |
| -- Definition of the class-wide type and the tagged type |
| |
| -- If the controlling argument is itself a tag rather than a tagged |
| -- object, then use the class-wide type associated with the subprogram's |
| -- controlling type. This case can occur when a call to an inherited |
| -- primitive has an actual that originated from a default parameter |
| -- given by a tag-indeterminate call and when there is no other |
| -- controlling argument providing the tag (AI-239 requires dispatching). |
| -- This capability of dispatching directly by tag is also needed by the |
| -- implementation of AI-260 (for the generic dispatching constructors). |
| |
| if 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 (Find_Dispatching_Type (Subp)); |
| |
| -- Class_Wide_Type is applied to the expressions used to initialize |
| -- CW_Typ, to ensure that CW_Typ always denotes a class-wide type, since |
| -- there are cases where the controlling type is resolved to a specific |
| -- type (such as for designated types of arguments such as CW'Access). |
| |
| elsif Is_Access_Type (Etype (Ctrl_Arg)) then |
| CW_Typ := Class_Wide_Type (Designated_Type (Etype (Ctrl_Arg))); |
| |
| else |
| CW_Typ := Class_Wide_Type (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; |
| |
| -- Dispatching call to C++ primitive. Create a new parameter list |
| -- with no tag checks. |
| |
| if Is_CPP_Class (Typ) then |
| 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; |
| |
| -- Dispatching call to Ada primitive |
| |
| 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 := Empty; |
| |
| begin |
| if Present (Old_Formal) then |
| New_Formal := New_Copy (Old_Formal); |
| Set_First_Entity (Subp_Typ, New_Formal); |
| Param := First_Actual (Call_Node); |
| |
| loop |
| Set_Scope (New_Formal, Subp_Typ); |
| |
| -- Change all the controlling argument types to be class-wide |
| -- to avoid a recursion in dispatching. |
| |
| if Is_Controlling_Formal (New_Formal) then |
| Set_Etype (New_Formal, Etype (Param)); |
| end if; |
| |
| if 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_Next_Entity (New_Formal, Empty); |
| Set_Last_Entity (Subp_Typ, Extra); |
| end if; |
| |
| -- Now that the explicit formals have been duplicated, any extra |
| -- formals needed by the subprogram must be created. |
| |
| if Present (Extra) then |
| Set_Extra_Formal (Extra, Empty); |
| end if; |
| |
| Create_Extra_Formals (Subp_Typ); |
| 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); |
| |
| -- Extract the tag from an unchecked type conversion. Done to avoid |
| -- the expansion of additional code just to obtain the value of such |
| -- tag because the current management of interface type conversions |
| -- generates in some cases this unchecked type conversion with the |
| -- tag of the object (see Expand_Interface_Conversion). |
| |
| elsif Nkind (Ctrl_Arg) = N_Unchecked_Type_Conversion |
| and then |
| (Etype (Expression (Ctrl_Arg)) = RTE (RE_Tag) |
| or else |
| (RTE_Available (RE_Interface_Tag) |
| and then |
| Etype (Expression (Ctrl_Arg)) = RTE (RE_Interface_Tag))) |
| then |
| Controlling_Tag := Duplicate_Subexpr (Expression (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; |
| |
| -- Handle dispatching calls to predefined primitives |
| |
| if Is_Predefined_Dispatching_Operation (Subp) |
| or else Is_Predefined_Dispatching_Alias (Subp) |
| then |
| New_Call_Name := |
| Unchecked_Convert_To (Subp_Ptr_Typ, |
| Build_Get_Predefined_Prim_Op_Address (Loc, |
| Tag_Node => Controlling_Tag, |
| Position => DT_Position (Subp))); |
| |
| -- Handle dispatching calls to user-defined primitives |
| |
| else |
| New_Call_Name := |
| Unchecked_Convert_To (Subp_Ptr_Typ, |
| Build_Get_Prim_Op_Address (Loc, |
| Typ => Find_Dispatching_Type (Subp), |
| Tag_Node => Controlling_Tag, |
| Position => DT_Position (Subp))); |
| end if; |
| |
| if Nkind (Call_Node) = N_Function_Call then |
| |
| New_Call := |
| Make_Function_Call (Loc, |
| Name => New_Call_Name, |
| Parameter_Associations => New_Params); |
| |
| -- If this is a dispatching "=", we must first compare the tags so |
| -- we generate: x.tag = y.tag and then x = y |
| |
| if Subp = Eq_Prim_Op then |
| Param := First_Actual (Call_Node); |
| New_Call := |
| Make_And_Then (Loc, |
| Left_Opnd => |
| Make_Op_Eq (Loc, |
| Left_Opnd => |
| Make_Selected_Component (Loc, |
| Prefix => New_Value (Param), |
| Selector_Name => |
| New_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; |
| |
| else |
| New_Call := |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Call_Name, |
| Parameter_Associations => New_Params); |
| end if; |
| |
| Rewrite (Call_Node, New_Call); |
| |
| -- Suppress all checks during the analysis of the expanded code |
| -- to avoid the generation of spureous warnings under ZFP run-time. |
| |
| Analyze_And_Resolve (Call_Node, Call_Typ, Suppress => All_Checks); |
| end Expand_Dispatching_Call; |
| |
| --------------------------------- |
| -- Expand_Interface_Conversion -- |
| --------------------------------- |
| |
| procedure Expand_Interface_Conversion |
| (N : Node_Id; |
| Is_Static : Boolean := True) |
| is |
| Loc : constant Source_Ptr := Sloc (N); |
| Etyp : constant Entity_Id := Etype (N); |
| Operand : constant Node_Id := Expression (N); |
| Operand_Typ : Entity_Id := Etype (Operand); |
| Func : Node_Id; |
| Iface_Typ : Entity_Id := Etype (N); |
| Iface_Tag : Entity_Id; |
| |
| begin |
| -- Ada 2005 (AI-345): Handle synchronized interface type derivations |
| |
| if Is_Concurrent_Type (Operand_Typ) then |
| Operand_Typ := Base_Type (Corresponding_Record_Type (Operand_Typ)); |
| end if; |
| |
| -- Handle access to class-wide interface types |
| |
| 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 := Root_Type (Iface_Typ); |
| end if; |
| |
| pragma Assert (not Is_Static |
| or else (not Is_Class_Wide_Type (Iface_Typ) |
| and then Is_Interface (Iface_Typ))); |
| |
| if VM_Target /= No_VM then |
| |
| -- For VM, just do a conversion ??? |
| |
| Rewrite (N, Unchecked_Convert_To (Etype (N), N)); |
| Analyze (N); |
| return; |
| end if; |
| |
| if not Is_Static then |
| |
| -- Give error if configurable run time and Displace not available |
| |
| if not RTE_Available (RE_Displace) then |
| Error_Msg_CRT ("abstract interface types", N); |
| return; |
| end if; |
| |
| -- Handle conversion of access-to-class-wide interface types. Target |
| -- can be an access to an object or an access to another class-wide |
| -- interface (see -1- and -2- in the following example): |
| |
| -- type Iface1_Ref is access all Iface1'Class; |
| -- type Iface2_Ref is access all Iface1'Class; |
| |
| -- Acc1 : Iface1_Ref := new ... |
| -- Obj : Obj_Ref := Obj_Ref (Acc); -- 1 |
| -- Acc2 : Iface2_Ref := Iface2_Ref (Acc); -- 2 |
| |
| if Is_Access_Type (Operand_Typ) then |
| pragma Assert |
| (Is_Interface (Directly_Designated_Type (Operand_Typ))); |
| |
| Rewrite (N, |
| Unchecked_Convert_To (Etype (N), |
| Make_Function_Call (Loc, |
| Name => New_Reference_To (RTE (RE_Displace), Loc), |
| Parameter_Associations => New_List ( |
| |
| Unchecked_Convert_To (RTE (RE_Address), |
| Relocate_Node (Expression (N))), |
| |
| New_Occurrence_Of |
| (Node (First_Elmt (Access_Disp_Table (Iface_Typ))), |
| Loc))))); |
| |
| Analyze (N); |
| return; |
| end if; |
| |
| Rewrite (N, |
| Make_Function_Call (Loc, |
| Name => New_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); |
| |
| -- If the target is a class-wide interface we 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_Esize (New_Itype); |
| Init_Size_Align (New_Itype); |
| Set_Directly_Designated_Type (New_Itype, Etyp); |
| |
| Rewrite (N, |
| Make_Explicit_Dereference (Loc, |
| Prefix => |
| Unchecked_Convert_To (New_Itype, Relocate_Node (N)))); |
| Analyze (N); |
| Freeze_Itype (New_Itype, N); |
| |
| return; |
| end; |
| end if; |
| |
| Iface_Tag := Find_Interface_Tag (Operand_Typ, Iface_Typ); |
| pragma Assert (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 : Address) return Iface_Typ is |
| -- type Op_Typ is access all Operand_Typ; |
| -- Aux : Op_Typ := To_Op_Typ (O); |
| -- begin |
| -- if O = Null_Address then |
| -- return null; |
| -- else |
| -- return Iface_Typ!(Aux.Iface_Tag'Address); |
| -- end if; |
| -- end Func; |
| |
| declare |
| Desig_Typ : Entity_Id; |
| Fent : Entity_Id; |
| New_Typ_Decl : Node_Id; |
| Stats : List_Id; |
| |
| begin |
| Desig_Typ := Etype (Expression (N)); |
| |
| if Is_Access_Type (Desig_Typ) then |
| Desig_Typ := Directly_Designated_Type (Desig_Typ); |
| end if; |
| |
| if Is_Concurrent_Type (Desig_Typ) then |
| Desig_Typ := Base_Type (Corresponding_Record_Type (Desig_Typ)); |
| end if; |
| |
| New_Typ_Decl := |
| Make_Full_Type_Declaration (Loc, |
| Defining_Identifier => |
| Make_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 (Desig_Typ, Loc))); |
| |
| Stats := New_List ( |
| Make_Simple_Return_Statement (Loc, |
| Unchecked_Convert_To (Etype (N), |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| Make_Selected_Component (Loc, |
| Prefix => |
| Unchecked_Convert_To |
| (Defining_Identifier (New_Typ_Decl), |
| Make_Identifier (Loc, Name_uO)), |
| Selector_Name => |
| New_Occurrence_Of (Iface_Tag, Loc)), |
| Attribute_Name => Name_Address)))); |
| |
| -- If the type is null-excluding, no need for the null branch. |
| -- Otherwise we need to check for it and return null. |
| |
| if not Can_Never_Be_Null (Etype (N)) then |
| Stats := New_List ( |
| Make_If_Statement (Loc, |
| Condition => |
| Make_Op_Eq (Loc, |
| Left_Opnd => Make_Identifier (Loc, Name_uO), |
| Right_Opnd => New_Reference_To |
| (RTE (RE_Null_Address), Loc)), |
| |
| Then_Statements => New_List ( |
| Make_Simple_Return_Statement (Loc, |
| Make_Null (Loc))), |
| Else_Statements => Stats)); |
| end if; |
| |
| Fent := |
| Make_Defining_Identifier (Loc, |
| New_Internal_Name ('F')); |
| |
| Func := |
| Make_Subprogram_Body (Loc, |
| Specification => |
| Make_Function_Specification (Loc, |
| Defining_Unit_Name => Fent, |
| |
| Parameter_Specifications => New_List ( |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uO), |
| Parameter_Type => |
| New_Reference_To (RTE (RE_Address), Loc))), |
| |
| Result_Definition => |
| New_Reference_To (Etype (N), Loc)), |
| |
| Declarations => New_List (New_Typ_Decl), |
| |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, Stats)); |
| |
| -- Place function body before the expression containing the |
| -- conversion. We suppress all checks because the body of the |
| -- internally generated function already takes care of the case |
| -- in which the actual is null; therefore there is no need to |
| -- double check that the pointer is not null when the program |
| -- executes the alternative that performs the type conversion). |
| |
| Insert_Action (N, Func, Suppress => All_Checks); |
| |
| if Is_Access_Type (Etype (Expression (N))) then |
| |
| -- Generate: Func (Address!(Expression)) |
| |
| Rewrite (N, |
| Make_Function_Call (Loc, |
| Name => New_Reference_To (Fent, Loc), |
| Parameter_Associations => New_List ( |
| Unchecked_Convert_To (RTE (RE_Address), |
| Relocate_Node (Expression (N)))))); |
| |
| else |
| -- Generate: Func (Operand_Typ!(Expression)'Address) |
| |
| Rewrite (N, |
| Make_Function_Call (Loc, |
| Name => New_Reference_To (Fent, Loc), |
| Parameter_Associations => New_List ( |
| Make_Attribute_Reference (Loc, |
| Prefix => Unchecked_Convert_To (Operand_Typ, |
| Relocate_Node (Expression (N))), |
| Attribute_Name => Name_Address)))); |
| end if; |
| end; |
| end if; |
| |
| Analyze (N); |
| end Expand_Interface_Conversion; |
| |
| ------------------------------ |
| -- Expand_Interface_Actuals -- |
| ------------------------------ |
| |
| procedure Expand_Interface_Actuals (Call_Node : Node_Id) is |
| Actual : Node_Id; |
| Actual_Dup : Node_Id; |
| Actual_Typ : Entity_Id; |
| Anon : Entity_Id; |
| Conversion : Node_Id; |
| Formal : Entity_Id; |
| Formal_Typ : Entity_Id; |
| Subp : Entity_Id; |
| Formal_DDT : Entity_Id; |
| 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; |
| |
| -- Ada 2005 (AI-251): Look for interface type formals to force "this" |
| -- displacement |
| |
| Formal := First_Formal (Subp); |
| Actual := First_Actual (Call_Node); |
| while Present (Formal) loop |
| Formal_Typ := Etype (Formal); |
| |
| if 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) |
| and then Is_Class_Wide_Type (Formal_Typ) |
| then |
| -- No need to displace the pointer if the type of the actual |
| -- coindices with the type of the formal. |
| |
| if Actual_Typ = Formal_Typ then |
| null; |
| |
| -- No need to displace the pointer if the interface type is |
| -- a parent of the type of the actual because in this case the |
| -- interface primitives are located in the primary dispatch table. |
| |
| elsif Is_Parent (Formal_Typ, Actual_Typ) then |
| null; |
| |
| -- Implicit conversion to the class-wide formal type to force |
| -- the displacement of the pointer. |
| |
| else |
| Conversion := Convert_To (Formal_Typ, Relocate_Node (Actual)); |
| Rewrite (Actual, Conversion); |
| Analyze_And_Resolve (Actual, Formal_Typ); |
| end if; |
| |
| -- Access to class-wide interface type |
| |
| elsif Is_Access_Type (Formal_Typ) |
| and then Is_Interface (Formal_DDT) |
| and then Is_Class_Wide_Type (Formal_DDT) |
| and then Interface_Present_In_Ancestor |
| (Typ => Actual_DDT, |
| Iface => Etype (Formal_DDT)) |
| then |
| -- Handle attributes 'Access and 'Unchecked_Access |
| |
| if Nkind (Actual) = N_Attribute_Reference |
| and then |
| (Attribute_Name (Actual) = Name_Access |
| or else Attribute_Name (Actual) = Name_Unchecked_Access) |
| then |
| -- This case must have been handled by the analysis and |
| -- expansion of 'Access. The only exception is when types |
| -- match and no further expansion is required. |
| |
| pragma Assert (Base_Type (Etype (Prefix (Actual))) |
| = Base_Type (Formal_DDT)); |
| null; |
| |
| -- No need to displace the pointer if the type of the actual |
| -- coincides with the type of the formal. |
| |
| elsif Actual_DDT = Formal_DDT then |
| null; |
| |
| -- No need to displace the pointer if the interface type is |
| -- a parent of the type of the actual because in this case the |
| -- interface primitives are located in the primary dispatch table. |
| |
| elsif Is_Parent (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 -- |
| ---------------------------- |
| |
| procedure Expand_Interface_Thunk |
| (Prim : Node_Id; |
| Thunk_Id : out Entity_Id; |
| Thunk_Code : out Node_Id) |
| is |
| Loc : constant Source_Ptr := Sloc (Prim); |
| Actuals : constant List_Id := New_List; |
| Decl : constant List_Id := New_List; |
| Formals : constant List_Id := New_List; |
| |
| Controlling_Typ : Entity_Id; |
| Decl_1 : Node_Id; |
| Decl_2 : Node_Id; |
| Formal : Node_Id; |
| Target : Entity_Id; |
| Target_Formal : Entity_Id; |
| |
| begin |
| Thunk_Id := Empty; |
| Thunk_Code := Empty; |
| |
| -- 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", Prim); |
| return; |
| end if; |
| |
| -- Traverse the list of alias to find the final target |
| |
| Target := Prim; |
| while Present (Alias (Target)) loop |
| Target := Alias (Target); |
| end loop; |
| |
| -- In case of primitives that are functions without formals and |
| -- a controlling result there is no need to build the thunk. |
| |
| if not Present (First_Formal (Target)) then |
| pragma Assert (Ekind (Target) = E_Function |
| and then Has_Controlling_Result (Target)); |
| return; |
| end if; |
| |
| -- Duplicate the formals |
| |
| Formal := First_Formal (Target); |
| while Present (Formal) loop |
| Append_To (Formals, |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Sloc (Formal), |
| Chars => Chars (Formal)), |
| In_Present => In_Present (Parent (Formal)), |
| Out_Present => Out_Present (Parent (Formal)), |
| Parameter_Type => |
| New_Reference_To (Etype (Formal), Loc), |
| Expression => New_Copy_Tree (Expression (Parent (Formal))))); |
| |
| Next_Formal (Formal); |
| end loop; |
| |
| Controlling_Typ := Find_Dispatching_Type (Target); |
| |
| Target_Formal := First_Formal (Target); |
| Formal := First (Formals); |
| while Present (Formal) loop |
| if Ekind (Target_Formal) = E_In_Parameter |
| and then Ekind (Etype (Target_Formal)) = E_Anonymous_Access_Type |
| and then Directly_Designated_Type (Etype (Target_Formal)) |
| = Controlling_Typ |
| then |
| -- Generate: |
| |
| -- type T is access all <<type of the target formal>> |
| -- S : Storage_Offset := Storage_Offset!(Formal) |
| -- - Offset_To_Top (address!(Formal)) |
| |
| Decl_2 := |
| Make_Full_Type_Declaration (Loc, |
| Defining_Identifier => |
| Make_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 (Target_Formal)), 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 (Formal), 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 (Formal), Loc)))))); |
| |
| Append_To (Decl, Decl_2); |
| Append_To (Decl, Decl_1); |
| |
| -- Reference the new actual. Generate: |
| -- T!(S) |
| |
| Append_To (Actuals, |
| Unchecked_Convert_To |
| (Defining_Identifier (Decl_2), |
| New_Reference_To (Defining_Identifier (Decl_1), Loc))); |
| |
| elsif Etype (Target_Formal) = Controlling_Typ then |
| -- Generate: |
| |
| -- S1 : Storage_Offset := Storage_Offset!(Formal'Address) |
| -- - Offset_To_Top (Formal'Address) |
| -- S2 : Addr_Ptr := Addr_Ptr!(S1) |
| |
| 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 (Formal), 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 (Formal), 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 actual. Generate: |
| -- Target_Formal (S2.all) |
| |
| Append_To (Actuals, |
| Unchecked_Convert_To |
| (Etype (Target_Formal), |
| Make_Explicit_Dereference (Loc, |
| New_Reference_To (Defining_Identifier (Decl_2), Loc)))); |
| |
| -- No special management required for this actual |
| |
| else |
| Append_To (Actuals, |
| New_Reference_To (Defining_Identifier (Formal), Loc)); |
| end if; |
| |
| Next_Formal (Target_Formal); |
| Next (Formal); |
| end loop; |
| |
| Thunk_Id := |
| Make_Defining_Identifier (Loc, |
| Chars => New_Internal_Name ('T')); |
| |
| Set_Is_Thunk (Thunk_Id); |
| |
| if Ekind (Target) = E_Procedure then |
| Thunk_Code := |
| Make_Subprogram_Body (Loc, |
| Specification => |
| Make_Procedure_Specification (Loc, |
| Defining_Unit_Name => Thunk_Id, |
| Parameter_Specifications => Formals), |
| Declarations => Decl, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => New_List ( |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (Target, Loc), |
| Parameter_Associations => Actuals)))); |
| |
| else pragma Assert (Ekind (Target) = E_Function); |
| |
| Thunk_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_Simple_Return_Statement (Loc, |
| Make_Function_Call (Loc, |
| Name => New_Occurrence_Of (Target, Loc), |
| Parameter_Associations => Actuals))))); |
| end if; |
| end Expand_Interface_Thunk; |
| |
| ------------ |
| -- Has_DT -- |
| ------------ |
| |
| function Has_DT (Typ : Entity_Id) return Boolean is |
| begin |
| return not Is_Interface (Typ) |
| and then not Restriction_Active (No_Dispatching_Calls); |
| end Has_DT; |
| |
| ------------------------------------- |
| -- Is_Predefined_Dispatching_Alias -- |
| ------------------------------------- |
| |
| function Is_Predefined_Dispatching_Alias (Prim : Entity_Id) return Boolean |
| is |
| E : Entity_Id; |
| |
| begin |
| if not Is_Predefined_Dispatching_Operation (Prim) |
| and then Present (Alias (Prim)) |
| then |
| E := Prim; |
| while Present (Alias (E)) loop |
| E := Alias (E); |
| end loop; |
| |
| if Is_Predefined_Dispatching_Operation (E) then |
| return True; |
| end if; |
| end if; |
| |
| return False; |
| end Is_Predefined_Dispatching_Alias; |
| |
| ---------------------------------------- |
| -- Make_Disp_Asynchronous_Select_Body -- |
| ---------------------------------------- |
| |
| -- For interface types, generate: |
| |
| -- procedure _Disp_Asynchronous_Select |
| -- (T : in out <Typ>; |
| -- S : Integer; |
| -- P : System.Address; |
| -- B : out System.Storage_Elements.Dummy_Communication_Block; |
| -- F : out Boolean) |
| -- is |
| -- begin |
| -- null; |
| -- end _Disp_Asynchronous_Select; |
| |
| -- For protected types, generate: |
| |
| -- procedure _Disp_Asynchronous_Select |
| -- (T : in out <Typ>; |
| -- S : Integer; |
| -- P : System.Address; |
| -- B : out System.Storage_Elements.Dummy_Communication_Block; |
| -- F : out Boolean) |
| -- is |
| -- I : Integer := |
| -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S)); |
| -- Bnn : System.Tasking.Protected_Objects.Operations. |
| -- Communication_Block; |
| -- begin |
| -- System.Tasking.Protected_Objects.Operations.Protected_Entry_Call |
| -- (T._object'Access, |
| -- System.Tasking.Protected_Objects.Protected_Entry_Index (I), |
| -- P, |
| -- System.Tasking.Asynchronous_Call, |
| -- Bnn); |
| -- B := System.Storage_Elements.Dummy_Communication_Block (Bnn); |
| -- end _Disp_Asynchronous_Select; |
| |
| -- For task types, generate: |
| |
| -- procedure _Disp_Asynchronous_Select |
| -- (T : in out <Typ>; |
| -- S : Integer; |
| -- P : System.Address; |
| -- B : out System.Storage_Elements.Dummy_Communication_Block; |
| -- F : out Boolean) |
| -- is |
| -- I : Integer := |
| -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S)); |
| -- begin |
| -- System.Tasking.Rendezvous.Task_Entry_Call |
| -- (T._task_id, |
| -- System.Tasking.Task_Entry_Index (I), |
| -- P, |
| -- System.Tasking.Asynchronous_Call, |
| -- F); |
| -- end _Disp_Asynchronous_Select; |
| |
| function Make_Disp_Asynchronous_Select_Body |
| (Typ : Entity_Id) return Node_Id |
| is |
| Com_Block : Entity_Id; |
| Conc_Typ : Entity_Id := Empty; |
| Decls : constant List_Id := New_List; |
| 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 := |
| -- Ada.Tags.Get_Entry_Index (Ada.Tags.Tag! (<type>VP), S); |
| |
| -- where I will be used to capture the entry index of the primitive |
| -- wrapper at position S. |
| |
| 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_Function_Call (Loc, |
| Name => |
| New_Reference_To (RTE (RE_Get_Entry_Index), Loc), |
| Parameter_Associations => |
| 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: |
| -- Bnn : Communication_Block; |
| |
| Com_Block := |
| Make_Defining_Identifier (Loc, New_Internal_Name ('B')); |
| |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => |
| Com_Block, |
| Object_Definition => |
| New_Reference_To (RTE (RE_Communication_Block), Loc))); |
| |
| -- Generate: |
| -- Protected_Entry_Call |
| -- (T._object'Access, -- Object |
| -- Protected_Entry_Index! (I), -- E |
| -- P, -- Uninterpreted_Data |
| -- Asynchronous_Call, -- Mode |
| -- Bnn); -- Communication_Block |
| |
| -- where T is the protected object, I is the entry index, P 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), |
| |
| New_Reference_To (Com_Block, Loc)))); -- comm block |
| |
| -- Generate: |
| -- B := Dummy_Communication_Block (Bnn); |
| |
| Append_To (Stmts, |
| Make_Assignment_Statement (Loc, |
| Name => |
| Make_Identifier (Loc, Name_uB), |
| Expression => |
| Make_Unchecked_Type_Conversion (Loc, |
| Subtype_Mark => |
| New_Reference_To ( |
| RTE (RE_Dummy_Communication_Block), Loc), |
| Expression => |
| New_Reference_To (Com_Block, Loc)))); |
| |
| else |
| pragma Assert (Ekind (Conc_Typ) = E_Task_Type); |
| |
| -- Generate: |
| -- Task_Entry_Call |
| -- (T._task_id, -- Acceptor |
| -- Task_Entry_Index! (I), -- E |
| -- P, -- Uninterpreted_Data |
| -- Asynchronous_Call, -- Mode |
| -- F); -- Rendezvous_Successful |
| |
| -- where T is the task object, I is the entry index, P 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 : in out Typ; -- Object parameter |
| -- S : Integer; -- Primitive operation slot |
| -- P : Address; -- Wrapped parameters |
| -- B : out Dummy_Communication_Block; -- Communication block dummy |
| -- F : out Boolean; -- Status flag |
| |
| Append_List_To (Params, New_List ( |
| |
| 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), |
| |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uS), |
| Parameter_Type => |
| New_Reference_To (Standard_Integer, Loc)), |
| |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uP), |
| Parameter_Type => |
| New_Reference_To (RTE (RE_Address), Loc)), |
| |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uB), |
| Parameter_Type => |
| New_Reference_To (RTE (RE_Dummy_Communication_Block), Loc), |
| Out_Present => True), |
| |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uF), |
| Parameter_Type => |
| New_Reference_To (Standard_Boolean, Loc), |
| Out_Present => True))); |
| |
| return |
| Make_Procedure_Specification (Loc, |
| Defining_Unit_Name => Def_Id, |
| Parameter_Specifications => Params); |
| end Make_Disp_Asynchronous_Select_Spec; |
| |
| --------------------------------------- |
| -- Make_Disp_Conditional_Select_Body -- |
| --------------------------------------- |
| |
| -- For interface types, generate: |
| |
| -- procedure _Disp_Conditional_Select |
| -- (T : in out <Typ>; |
| -- S : Integer; |
| -- P : System.Address; |
| -- C : out Ada.Tags.Prim_Op_Kind; |
| -- F : out Boolean) |
| -- is |
| -- begin |
| -- null; |
| -- end _Disp_Conditional_Select; |
| |
| -- For protected types, generate: |
| |
| -- procedure _Disp_Conditional_Select |
| -- (T : in out <Typ>; |
| -- S : Integer; |
| -- P : System.Address; |
| -- C : out Ada.Tags.Prim_Op_Kind; |
| -- F : out Boolean) |
| -- is |
| -- I : Integer; |
| -- Bnn : System.Tasking.Protected_Objects.Operations. |
| -- Communication_Block; |
| |
| -- begin |
| -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag (<Typ>VP, S)); |
| |
| -- if C = Ada.Tags.POK_Procedure |
| -- or else C = Ada.Tags.POK_Protected_Procedure |
| -- or else C = Ada.Tags.POK_Task_Procedure |
| -- then |
| -- F := True; |
| -- return; |
| -- end if; |
| |
| -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S)); |
| -- System.Tasking.Protected_Objects.Operations.Protected_Entry_Call |
| -- (T.object'Access, |
| -- System.Tasking.Protected_Objects.Protected_Entry_Index (I), |
| -- P, |
| -- System.Tasking.Conditional_Call, |
| -- Bnn); |
| -- F := not Cancelled (Bnn); |
| -- end _Disp_Conditional_Select; |
| |
| -- For task types, generate: |
| |
| -- procedure _Disp_Conditional_Select |
| -- (T : in out <Typ>; |
| -- S : Integer; |
| -- P : System.Address; |
| -- C : out Ada.Tags.Prim_Op_Kind; |
| -- F : out Boolean) |
| -- is |
| -- I : Integer; |
| |
| -- begin |
| -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S)); |
| -- System.Tasking.Rendezvous.Task_Entry_Call |
| -- (T._task_id, |
| -- System.Tasking.Task_Entry_Index (I), |
| -- P, |
| -- System.Tasking.Conditional_Call, |
| -- F); |
| -- end _Disp_Conditional_Select; |
| |
| function Make_Disp_Conditional_Select_Body |
| (Typ : Entity_Id) return Node_Id |
| is |
| Loc : constant Source_Ptr := Sloc (Typ); |
| Blk_Nam : Entity_Id; |
| Conc_Typ : Entity_Id := Empty; |
| Decls : constant List_Id := New_List; |
| 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 := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag! (<type>VP), S); |
| |
| -- if C = POK_Procedure |
| -- or else C = POK_Protected_Procedure |
| -- or else C = POK_Task_Procedure; |
| -- then |
| -- F := True; |
| -- return; |
| -- end if; |
| |
| Build_Common_Dispatching_Select_Statements (Loc, 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 := Ada.Tags.Get_Entry_Index (Ada.Tags.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_Function_Call (Loc, |
| Name => |
| New_Reference_To (RTE (RE_Get_Entry_Index), Loc), |
| Parameter_Associations => |
| 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, -- Object |
| -- Protected_Entry_Index! (I), -- E |
| -- P, -- Uninterpreted_Data |
| -- Conditional_Call, -- Mode |
| -- Bnn); -- Block |
| |
| -- where T is the protected object, I is the entry index, P are |
| -- the wrapped parameters and Bnn is the name of the communication |
| -- block. |
| |
| Append_To (Stmts, |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_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: |
| -- Task_Entry_Call |
| -- (T._task_id, -- Acceptor |
| -- Task_Entry_Index! (I), -- E |
| -- P, -- Uninterpreted_Data |
| -- Conditional_Call, -- Mode |
| -- F); -- Rendezvous_Successful |
| |
| -- where T is the task object, I is the entry index, P are the |
| -- wrapped parameters and F is the status flag. |
| |
| Append_To (Stmts, |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_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 : in out Typ; -- Object parameter |
| -- S : Integer; -- Primitive operation slot |
| -- P : Address; -- Wrapped parameters |
| -- C : out Prim_Op_Kind; -- Call kind |
| -- F : out Boolean; -- Status flag |
| |
| Append_List_To (Params, New_List ( |
| |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uT), |
| Parameter_Type => |
| New_Reference_To (Typ, Loc), |
| In_Present => True, |
| Out_Present => True), |
| |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uS), |
| Parameter_Type => |
| New_Reference_To (Standard_Integer, Loc)), |
| |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uP), |
| Parameter_Type => |
| New_Reference_To (RTE (RE_Address), Loc)), |
| |
| 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), |
| |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uF), |
| Parameter_Type => |
| New_Reference_To (Standard_Boolean, Loc), |
| Out_Present => True))); |
| |
| return |
| Make_Procedure_Specification (Loc, |
| Defining_Unit_Name => Def_Id, |
| Parameter_Specifications => Params); |
| end Make_Disp_Conditional_Select_Spec; |
| |
| ------------------------------------- |
| -- Make_Disp_Get_Prim_Op_Kind_Body -- |
| ------------------------------------- |
| |
| function Make_Disp_Get_Prim_Op_Kind_Body |
| (Typ : Entity_Id) return Node_Id |
| is |
| Loc : constant Source_Ptr := Sloc (Typ); |
| 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_Function_Call (Loc, |
| Name => |
| New_Reference_To (RTE (RE_Get_Prim_Op_Kind), Loc), |
| Parameter_Associations => 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 : in out Typ; -- Object parameter |
| -- S : Integer; -- Primitive operation slot |
| -- C : out Prim_Op_Kind; -- Call kind |
| |
| Append_List_To (Params, New_List ( |
| |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uT), |
| Parameter_Type => |
| New_Reference_To (Typ, Loc), |
| In_Present => True, |
| Out_Present => True), |
| |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uS), |
| Parameter_Type => |
| New_Reference_To (Standard_Integer, Loc)), |
| |
| 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))); |
| |
| return |
| Make_Procedure_Specification (Loc, |
| Defining_Unit_Name => Def_Id, |
| Parameter_Specifications => Params); |
| end Make_Disp_Get_Prim_Op_Kind_Spec; |
| |
| -------------------------------- |
| -- Make_Disp_Get_Task_Id_Body -- |
| -------------------------------- |
| |
| function Make_Disp_Get_Task_Id_Body |
| (Typ : Entity_Id) return Node_Id |
| is |
| Loc : constant Source_Ptr := Sloc (Typ); |
| Ret : Node_Id; |
| |
| begin |
| pragma Assert (not Restriction_Active (No_Dispatching_Calls)); |
| |
| if Is_Concurrent_Record_Type (Typ) |
| and then Ekind (Corresponding_Concurrent_Type (Typ)) = E_Task_Type |
| then |
| -- Generate: |
| -- return To_Address (_T._task_id); |
| |
| Ret := |
| Make_Simple_Return_Statement (Loc, |
| Expression => |
| Make_Unchecked_Type_Conversion (Loc, |
| Subtype_Mark => |
| New_Reference_To (RTE (RE_Address), 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 |
| -- Generate: |
| -- return Null_Address; |
| |
| Ret := |
| Make_Simple_Return_Statement (Loc, |
| Expression => |
| New_Reference_To (RTE (RE_Null_Address), Loc)); |
| end if; |
| |
| return |
| Make_Subprogram_Body (Loc, |
| Specification => |
| Make_Disp_Get_Task_Id_Spec (Typ), |
| Declarations => |
| New_List, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| New_List (Ret))); |
| end Make_Disp_Get_Task_Id_Body; |
| |
| -------------------------------- |
| -- Make_Disp_Get_Task_Id_Spec -- |
| -------------------------------- |
| |
| function Make_Disp_Get_Task_Id_Spec |
| (Typ : Entity_Id) return Node_Id |
| is |
| Loc : constant Source_Ptr := Sloc (Typ); |
| |
| begin |
| pragma Assert (not Restriction_Active (No_Dispatching_Calls)); |
| |
| return |
| Make_Function_Specification (Loc, |
| Defining_Unit_Name => |
| Make_Defining_Identifier (Loc, Name_uDisp_Get_Task_Id), |
| Parameter_Specifications => New_List ( |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uT), |
| Parameter_Type => |
| New_Reference_To (Typ, Loc))), |
| Result_Definition => |
| New_Reference_To (RTE (RE_Address), Loc)); |
| end Make_Disp_Get_Task_Id_Spec; |
| |
| ---------------------------- |
| -- Make_Disp_Requeue_Body -- |
| ---------------------------- |
| |
| function Make_Disp_Requeue_Body |
| (Typ : Entity_Id) return Node_Id |
| is |
| Loc : constant Source_Ptr := Sloc (Typ); |
| Conc_Typ : Entity_Id := Empty; |
| Stmts : constant List_Id := New_List; |
| |
| begin |
| pragma Assert (not Restriction_Active (No_Dispatching_Calls)); |
| |
| -- Null body is generated for interface types and non-concurrent |
| -- tagged types. |
| |
| if Is_Interface (Typ) |
| or else not Is_Concurrent_Record_Type (Typ) |
| then |
| return |
| Make_Subprogram_Body (Loc, |
| Specification => |
| Make_Disp_Requeue_Spec (Typ), |
| Declarations => |
| No_List, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| New_List (Make_Null_Statement (Loc)))); |
| end if; |
| |
| Conc_Typ := Corresponding_Concurrent_Type (Typ); |
| |
| if Ekind (Conc_Typ) = E_Protected_Type then |
| |
| -- Generate statements: |
| -- if F then |
| -- System.Tasking.Protected_Objects.Operations. |
| -- Requeue_Protected_Entry |
| -- (Protection_Entries_Access (P), |
| -- O._object'Unchecked_Access, |
| -- Protected_Entry_Index (I), |
| -- A); |
| -- else |
| -- System.Tasking.Protected_Objects.Operations. |
| -- Requeue_Task_To_Protected_Entry |
| -- (O._object'Unchecked_Access, |
| -- Protected_Entry_Index (I), |
| -- A); |
| -- end if; |
| |
| Append_To (Stmts, |
| Make_If_Statement (Loc, |
| Condition => |
| Make_Identifier (Loc, Name_uF), |
| |
| Then_Statements => |
| New_List ( |
| |
| -- Call to Requeue_Protected_Entry |
| |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Reference_To ( |
| RTE (RE_Requeue_Protected_Entry), Loc), |
| Parameter_Associations => |
| New_List ( |
| |
| Make_Unchecked_Type_Conversion (Loc, -- PEA (P) |
| Subtype_Mark => |
| New_Reference_To ( |
| RTE (RE_Protection_Entries_Access), Loc), |
| Expression => |
| Make_Identifier (Loc, Name_uP)), |
| |
| Make_Attribute_Reference (Loc, -- O._object'Acc |
| Attribute_Name => |
| Name_Unchecked_Access, |
| Prefix => |
| Make_Selected_Component (Loc, |
| Prefix => |
| Make_Identifier (Loc, Name_uO), |
| Selector_Name => |
| Make_Identifier (Loc, Name_uObject))), |
| |
| 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_uA)))), -- abort status |
| |
| Else_Statements => |
| New_List ( |
| |
| -- Call to Requeue_Task_To_Protected_Entry |
| |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Reference_To ( |
| RTE (RE_Requeue_Task_To_Protected_Entry), Loc), |
| Parameter_Associations => |
| New_List ( |
| |
| Make_Attribute_Reference (Loc, -- O._object'Acc |
| Attribute_Name => |
| Name_Unchecked_Access, |
| Prefix => |
| Make_Selected_Component (Loc, |
| Prefix => |
| Make_Identifier (Loc, Name_uO), |
| Selector_Name => |
| Make_Identifier (Loc, Name_uObject))), |
| |
| 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_uA)))))); -- abort status |
| else |
| pragma Assert (Is_Task_Type (Conc_Typ)); |
| |
| -- Generate: |
| -- if F then |
| -- System.Tasking.Rendezvous.Requeue_Protected_To_Task_Entry |
| -- (Protection_Entries_Access (P), |
| -- O._task_id, |
| -- Task_Entry_Index (I), |
| -- A); |
| -- else |
| -- System.Tasking.Rendezvous.Requeue_Task_Entry |
| -- (O._task_id, |
| -- Task_Entry_Index (I), |
| -- A); |
| -- end if; |
| |
| Append_To (Stmts, |
| Make_If_Statement (Loc, |
| Condition => |
| Make_Identifier (Loc, Name_uF), |
| |
| Then_Statements => |
| New_List ( |
| |
| -- Call to Requeue_Protected_To_Task_Entry |
| |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Reference_To ( |
| RTE (RE_Requeue_Protected_To_Task_Entry), Loc), |
| |
| Parameter_Associations => |
| New_List ( |
| |
| Make_Unchecked_Type_Conversion (Loc, -- PEA (P) |
| Subtype_Mark => |
| New_Reference_To ( |
| RTE (RE_Protection_Entries_Access), Loc), |
| Expression => |
| Make_Identifier (Loc, Name_uP)), |
| |
| Make_Selected_Component (Loc, -- O._task_id |
| Prefix => |
| Make_Identifier (Loc, Name_uO), |
| Selector_Name => |
| Make_Identifier (Loc, Name_uTask_Id)), |
| |
| 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_uA)))), -- abort status |
| |
| Else_Statements => |
| New_List ( |
| |
| -- Call to Requeue_Task_Entry |
| |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Reference_To (RTE (RE_Requeue_Task_Entry), Loc), |
| |
| Parameter_Associations => |
| New_List ( |
| |
| Make_Selected_Component (Loc, -- O._task_id |
| Prefix => |
| Make_Identifier (Loc, Name_uO), |
| Selector_Name => |
| Make_Identifier (Loc, Name_uTask_Id)), |
| |
| 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_uA)))))); -- abort status |
| end if; |
| |
| -- Even though no declarations are needed in both cases, we allocate |
| -- a list for entities added by Freeze. |
| |
| return |
| Make_Subprogram_Body (Loc, |
| Specification => |
| Make_Disp_Requeue_Spec (Typ), |
| Declarations => |
| New_List, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, Stmts)); |
| end Make_Disp_Requeue_Body; |
| |
| ---------------------------- |
| -- Make_Disp_Requeue_Spec -- |
| ---------------------------- |
| |
| function Make_Disp_Requeue_Spec |
| (Typ : Entity_Id) return Node_Id |
| is |
| Loc : constant Source_Ptr := Sloc (Typ); |
| |
| begin |
| pragma Assert (not Restriction_Active (No_Dispatching_Calls)); |
| |
| -- O : in out Typ; - Object parameter |
| -- F : Boolean; - Protected (True) / task (False) flag |
| -- P : Address; - Protection_Entries_Access value |
| -- I : Entry_Index - Index of entry call |
| -- A : Boolean - Abort flag |
| |
| -- Note that the Protection_Entries_Access value is represented as a |
| -- System.Address in order to avoid dragging in the tasking runtime |
| -- when compiling sources without tasking constructs. |
| |
| return |
| Make_Procedure_Specification (Loc, |
| Defining_Unit_Name => |
| Make_Defining_Identifier (Loc, Name_uDisp_Requeue), |
| |
| Parameter_Specifications => |
| New_List ( |
| |
| Make_Parameter_Specification (Loc, -- O |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uO), |
| Parameter_Type => |
| New_Reference_To (Typ, Loc), |
| In_Present => True, |
| Out_Present => True), |
| |
| Make_Parameter_Specification (Loc, -- F |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uF), |
| Parameter_Type => |
| New_Reference_To (Standard_Boolean, Loc)), |
| |
| Make_Parameter_Specification (Loc, -- P |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uP), |
| Parameter_Type => |
| New_Reference_To (RTE (RE_Address), Loc)), |
| |
| Make_Parameter_Specification (Loc, -- I |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uI), |
| Parameter_Type => |
| New_Reference_To (Standard_Integer, Loc)), |
| |
| Make_Parameter_Specification (Loc, -- A |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uA), |
| Parameter_Type => |
| New_Reference_To (Standard_Boolean, Loc)))); |
| end Make_Disp_Requeue_Spec; |
| |
| --------------------------------- |
| -- Make_Disp_Timed_Select_Body -- |
| --------------------------------- |
| |
| -- For interface types, generate: |
| |
| -- procedure _Disp_Timed_Select |
| -- (T : in out <Typ>; |
| -- S : Integer; |
| -- P : System.Address; |
| -- D : Duration; |
| -- M : Integer; |
| -- C : out Ada.Tags.Prim_Op_Kind; |
| -- F : out Boolean) |
| -- is |
| -- begin |
| -- null; |
| -- end _Disp_Timed_Select; |
| |
| -- For protected types, generate: |
| |
| -- procedure _Disp_Timed_Select |
| -- (T : in out <Typ>; |
| -- S : Integer; |
| -- P : System.Address; |
| -- D : Duration; |
| -- M : Integer; |
| -- C : out Ada.Tags.Prim_Op_Kind; |
| -- F : out Boolean) |
| -- is |
| -- I : Integer; |
| |
| -- begin |
| -- C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag (<Typ>VP), S); |
| |
| -- if C = Ada.Tags.POK_Procedure |
| -- or else C = Ada.Tags.POK_Protected_Procedure |
| -- or else C = Ada.Tags.POK_Task_Procedure |
| -- then |
| -- F := True; |
| -- return; |
| -- end if; |
| |
| -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP), S); |
| -- System.Tasking.Protected_Objects.Operations. |
| -- Timed_Protected_Entry_Call |
| -- (T._object'Access, |
| -- System.Tasking.Protected_Objects.Protected_Entry_Index (I), |
| -- P, |
| -- D, |
| -- M, |
| -- F); |
| -- end _Disp_Timed_Select; |
| |
| -- For task types, generate: |
| |
| -- procedure _Disp_Timed_Select |
| -- (T : in out <Typ>; |
| -- S : Integer; |
| -- P : System.Address; |
| -- D : Duration; |
| -- M : Integer; |
| -- C : out Ada.Tags.Prim_Op_Kind; |
| -- F : out Boolean) |
| -- is |
| -- I : Integer; |
| |
| -- begin |
| -- I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP), S); |
| -- System.Tasking.Rendezvous.Timed_Task_Entry_Call |
| -- (T._task_id, |
| -- System.Tasking.Task_Entry_Index (I), |
| -- P, |
| -- D, |
| -- M, |
| -- D); |
| -- end _Disp_Time_Select; |
| |
| function Make_Disp_Timed_Select_Body |
| (Typ : Entity_Id) return Node_Id |
| is |
| Loc : constant Source_Ptr := Sloc (Typ); |
| Conc_Typ : Entity_Id := Empty; |
| Decls : constant List_Id := New_List; |
| 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; |
| |
| Build_Common_Dispatching_Select_Statements (Loc, 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_Function_Call (Loc, |
| Name => |
| New_Reference_To (RTE (RE_Get_Entry_Index), Loc), |
| Parameter_Associations => |
| 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 : in out Typ; -- Object parameter |
| -- S : Integer; -- Primitive operation slot |
| -- P : Address; -- Wrapped parameters |
| -- D : Duration; -- Delay |
| -- M : Integer; -- Delay Mode |
| -- C : out Prim_Op_Kind; -- Call kind |
| -- F : out Boolean; -- Status flag |
| |
| Append_List_To (Params, New_List ( |
| |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uT), |
| Parameter_Type => |
| New_Reference_To (Typ, Loc), |
| In_Present => True, |
| Out_Present => True), |
| |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uS), |
| Parameter_Type => |
| New_Reference_To (Standard_Integer, Loc)), |
| |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uP), |
| Parameter_Type => |
| New_Reference_To (RTE (RE_Address), Loc)), |
| |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uD), |
| Parameter_Type => |
| New_Reference_To (Standard_Duration, Loc)), |
| |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_uM), |
| Parameter_Type => |
| New_Reference_To (Standard_Integer, Loc)), |
| |
| 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))); |
| |
| 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)); |
| |
| return |
| Make_Procedure_Specification (Loc, |
| Defining_Unit_Name => Def_Id, |
| Parameter_Specifications => Params); |
| end Make_Disp_Timed_Select_Spec; |
| |
| ------------- |
| -- Make_DT -- |
| ------------- |
| |
| -- The frontend supports two models for expanding dispatch tables |
| -- associated with library-level defined tagged types: statically |
| -- and non-statically allocated dispatch tables. In the former case |
| -- the object containing the dispatch table is constant and it is |
| -- initialized by means of a positional aggregate. In the latter case, |
| -- the object containing the dispatch table is a variable which is |
| -- initialized by means of assignments. |
| |
| -- In case of locally defined tagged types, the object containing the |
| -- object containing the dispatch table is always a variable (instead |
| -- of a constant). This is currently required to give support to late |
| -- overriding of primitives. For example: |
| |
| -- procedure Example is |
| -- package Pkg is |
| -- type T1 is tagged null record; |
| -- procedure Prim (O : T1); |
| -- end Pkg; |
| |
| -- type T2 is new Pkg.T1 with null record; |
| -- procedure Prim (X : T2) is -- late overriding |
| -- begin |
| -- ... |
| -- ... |
| -- end; |
| |
| function Make_DT (Typ : Entity_Id; N : Node_Id := Empty) return List_Id is |
| Loc : constant Source_Ptr := Sloc (Typ); |
| |
| Max_Predef_Prims : constant Int := |
| UI_To_Int |
| (Intval |
| (Expression |
| (Parent (RTE (RE_Max_Predef_Prims))))); |
| |
| procedure Check_Premature_Freezing (Subp : Entity_Id; Typ : Entity_Id); |
| -- Verify that all non-tagged types in the profile of a subprogram |
| -- are frozen at the point the subprogram is frozen. This enforces |
| -- the rule on RM 13.14 (14) as modified by AI05-019. At the point a |
| -- subprogram is frozen, enough must be known about it to build the |
| -- activation record for it, which requires at least that the size of |
| -- all parameters be known. Controlling arguments are by-reference, |
| -- and therefore the rule only applies to non-tagged types. |
| -- Typical violation of the rule involves an object declaration that |
| -- freezes a tagged type, when one of its primitive operations has a |
| -- type in its profile whose full view has not been analyzed yet. |
| |
| procedure Export_DT (Typ : Entity_Id; DT : Entity_Id); |
| -- Export the dispatch table entity DT of tagged type Typ. Required to |
| -- generate forward references and statically allocate the table. |
| |
| procedure Make_Secondary_DT |
| (Typ : Entity_Id; |
| Iface : Entity_Id; |
| Num_Iface_Prims : Nat; |
| Iface_DT_Ptr : Entity_Id; |
| Build_Thunks : Boolean; |
| Result : List_Id); |
| -- Ada 2005 (AI-251): Expand the declarations for a Secondary Dispatch |
| -- Table of Typ associated with Iface. Each abstract interface of Typ |
| -- has two secondary dispatch tables: one containing pointers to thunks |
| -- and another containing pointers to the primitives covering the |
| -- interface primitives. The former secondary table is generated when |
| -- Build_Thunks is True, and provides common support for dispatching |
| -- calls through interface types; the latter secondary table is |
| -- generated when Build_Thunks is False, and provides support for |
| -- Generic Dispatching Constructors that dispatch calls through |
| -- interface types. |
| |
| ------------------------------ |
| -- Check_Premature_Freezing -- |
| ------------------------------ |
| |
| procedure Check_Premature_Freezing (Subp : Entity_Id; Typ : Entity_Id) is |
| begin |
| if Present (N) |
| and then Is_Private_Type (Typ) |
| and then No (Full_View (Typ)) |
| and then not Is_Generic_Type (Typ) |
| and then not Is_Tagged_Type (Typ) |
| and then not Is_Frozen (Typ) |
| then |
| Error_Msg_Sloc := Sloc (Subp); |
| Error_Msg_NE |
| ("declaration must appear after completion of type &", N, Typ); |
| Error_Msg_NE |
| ("\which is an untagged type in the profile of" |
| & " primitive operation & declared#", |
| N, Subp); |
| end if; |
| end Check_Premature_Freezing; |
| |
| --------------- |
| -- Export_DT -- |
| --------------- |
| |
| procedure Export_DT (Typ : Entity_Id; DT : Entity_Id) is |
| begin |
| Set_Is_Statically_Allocated (DT); |
| Set_Is_True_Constant (DT); |
| Set_Is_Exported (DT); |
| |
| pragma Assert (Present (Dispatch_Table_Wrapper (Typ))); |
| Get_External_Name (Dispatch_Table_Wrapper (Typ), True); |
| Set_Interface_Name (DT, |
| Make_String_Literal (Loc, |
| Strval => String_From_Name_Buffer)); |
| |
| -- Ensure proper Sprint output of this implicit importation |
| |
| Set_Is_Internal (DT); |
| Set_Is_Public (DT); |
| end Export_DT; |
| |
| ----------------------- |
| -- Make_Secondary_DT -- |
| ----------------------- |
| |
| procedure Make_Secondary_DT |
| (Typ : Entity_Id; |
| Iface : Entity_Id; |
| Num_Iface_Prims : Nat; |
| Iface_DT_Ptr : Entity_Id; |
| Build_Thunks : Boolean; |
| Result : List_Id) |
| is |
| Loc : constant Source_Ptr := Sloc (Typ); |
| Name_DT : constant Name_Id := New_Internal_Name ('T'); |
| Iface_DT : constant Entity_Id := |
| Make_Defining_Identifier (Loc, Name_DT); |
| Name_Predef_Prims : constant Name_Id := New_Internal_Name ('R'); |
| Predef_Prims : constant Entity_Id := |
| Make_Defining_Identifier (Loc, |
| Name_Predef_Prims); |
| DT_Constr_List : List_Id; |
| DT_Aggr_List : List_Id; |
| Empty_DT : Boolean := False; |
| Nb_Predef_Prims : Nat := 0; |
| Nb_Prim : Nat; |
| New_Node : Node_Id; |
| OSD : Entity_Id; |
| OSD_Aggr_List : List_Id; |
| Pos : Nat; |
| Prim : Entity_Id; |
| Prim_Elmt : Elmt_Id; |
| Prim_Ops_Aggr_List : List_Id; |
| |
| begin |
| -- Handle cases in which we do not generate statically allocated |
| -- dispatch tables. |
| |
| if not Building_Static_DT (Typ) then |
| Set_Ekind (Predef_Prims, E_Variable); |
| Set_Is_Statically_Allocated (Predef_Prims); |
| |
| Set_Ekind (Iface_DT, E_Variable); |
| Set_Is_Statically_Allocated (Iface_DT); |
| |
| -- Statically allocated dispatch tables and related entities are |
| -- constants. |
| |
| else |
| Set_Ekind (Predef_Prims, E_Constant); |
| Set_Is_Statically_Allocated (Predef_Prims); |
| Set_Is_True_Constant (Predef_Prims); |
| |
| Set_Ekind (Iface_DT, E_Constant); |
| Set_Is_Statically_Allocated (Iface_DT); |
| Set_Is_True_Constant (Iface_DT); |
| end if; |
| |
| -- 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. |
| |
| if Num_Iface_Prims = 0 then |
| Empty_DT := True; |
| Nb_Prim := 1; |
| else |
| Nb_Prim := Num_Iface_Prims; |
| end if; |
| |
| -- Generate: |
| |
| -- Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) := |
| -- (predef-prim-op-thunk-1'address, |
| -- predef-prim-op-thunk-2'address, |
| -- ... |
| -- predef-prim-op-thunk-n'address); |
| -- for Predef_Prims'Alignment use Address'Alignment |
| |
| -- Stage 1: Calculate the number of predefined primitives |
| |
| if not Building_Static_DT (Typ) then |
| Nb_Predef_Prims := Max_Predef_Prims; |
| else |
| Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); |
| while Present (Prim_Elmt) loop |
| Prim := Node (Prim_Elmt); |
| |
| if Is_Predefined_Dispatching_Operation (Prim) |
| and then not Is_Abstract_Subprogram (Prim) |
| then |
| Pos := UI_To_Int (DT_Position (Prim)); |
| |
| if Pos > Nb_Predef_Prims then |
| Nb_Predef_Prims := Pos; |
| end if; |
| end if; |
| |
| Next_Elmt (Prim_Elmt); |
| end loop; |
| end if; |
| |
| -- Stage 2: Create the thunks associated with the predefined |
| -- primitives and save their entity to fill the aggregate. |
| |
| declare |
| Prim_Table : array (Nat range 1 .. Nb_Predef_Prims) of Entity_Id; |
| Thunk_Id : Entity_Id; |
| Thunk_Code : Node_Id; |
| |
| begin |
| Prim_Ops_Aggr_List := New_List; |
| Prim_Table := (others => Empty); |
| |
| if Building_Static_DT (Typ) then |
| Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); |
| while Present (Prim_Elmt) loop |
| Prim := Node (Prim_Elmt); |
| |
| if Is_Predefined_Dispatching_Operation (Prim) |
| and then not Is_Abstract_Subprogram (Prim) |
| and then not Present (Prim_Table |
| (UI_To_Int (DT_Position (Prim)))) |
| then |
| if not Build_Thunks then |
| Prim_Table (UI_To_Int (DT_Position (Prim))) := |
| Alias (Prim); |
| |
| else |
| while Present (Alias (Prim)) loop |
| Prim := Alias (Prim); |
| end loop; |
| |
| Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code); |
| |
| if Present (Thunk_Id) then |
| Append_To (Result, Thunk_Code); |
| Prim_Table (UI_To_Int (DT_Position (Prim))) |
| := Thunk_Id; |
| end if; |
| end if; |
| end if; |
| |
| Next_Elmt (Prim_Elmt); |
| end loop; |
| end if; |
| |
| for J in Prim_Table'Range loop |
| if Present (Prim_Table (J)) then |
| New_Node := |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Reference_To (Prim_Table (J), Loc), |
| Attribute_Name => Name_Address); |
| else |
| New_Node := |
| New_Reference_To (RTE (RE_Null_Address), Loc); |
| end if; |
| |
| Append_To (Prim_Ops_Aggr_List, New_Node); |
| end loop; |
| |
| Append_To (Result, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Predef_Prims, |
| Constant_Present => Building_Static_DT (Typ), |
| Aliased_Present => True, |
| Object_Definition => |
| New_Reference_To (RTE (RE_Address_Array), Loc), |
| Expression => Make_Aggregate (Loc, |
| Expressions => Prim_Ops_Aggr_List))); |
| |
| Append_To (Result, |
| Make_Attribute_Definition_Clause (Loc, |
| Name => New_Reference_To (Predef_Prims, Loc), |
| Chars => Name_Alignment, |
| Expression => |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Reference_To (RTE (RE_Integer_Address), Loc), |
| Attribute_Name => Name_Alignment))); |
| end; |
| |
| -- Generate |
| |
| -- OSD : Ada.Tags.Object_Specific_Data (Nb_Prims) := |
| -- (OSD_Table => (1 => <value>, |
| -- ... |
| -- N => <value>)); |
| |
| -- Iface_DT : Dispatch_Table (Nb_Prims) := |
| -- ([ Signature => <sig-value> ], |
| -- Tag_Kind => <tag_kind-value>, |
| -- Predef_Prims => Predef_Prims'Address, |
| -- Offset_To_Top => 0, |
| -- OSD => OSD'Address, |
| -- Prims_Ptr => (prim-op-1'address, |
| -- prim-op-2'address, |
| -- ... |
| -- prim-op-n'address)); |
| |
| -- Stage 3: Initialize the discriminant and the record components |
| |
| DT_Constr_List := New_List; |
| DT_Aggr_List := New_List; |
| |
| -- Nb_Prim. If the tagged type has no primitives we add a dummy |
| -- slot whose address will be the tag of this type. |
| |
| if Nb_Prim = 0 then |
| New_Node := Make_Integer_Literal (Loc, 1); |
| else |
| New_Node := Make_Integer_Literal (Loc, Nb_Prim); |
| end if; |
| |
| Append_To (DT_Constr_List, New_Node); |
| Append_To (DT_Aggr_List, New_Copy (New_Node)); |
| |
| -- Signature |
| |
| if RTE_Record_Component_Available (RE_Signature) then |
| Append_To (DT_Aggr_List, |
| New_Reference_To (RTE (RE_Secondary_DT), Loc)); |
| end if; |
| |
| -- Tag_Kind |
| |
| if RTE_Record_Component_Available (RE_Tag_Kind) then |
| Append_To (DT_Aggr_List, Tagged_Kind (Typ)); |
| end if; |
| |
| -- Predef_Prims |
| |
| Append_To (DT_Aggr_List, |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Reference_To (Predef_Prims, Loc), |
| Attribute_Name => Name_Address)); |
| |
| -- Note: The correct value of Offset_To_Top will be set by the init |
| -- subprogram |
| |
| Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0)); |
| |
| -- Generate the Object Specific Data table required to dispatch calls |
| -- through synchronized interfaces. |
| |
| if Empty_DT |
| or else Is_Abstract_Type (Typ) |
| or else Is_Controlled (Typ) |
| or else Restriction_Active (No_Dispatching_Calls) |
| or else not Is_Limited_Type (Typ) |
| or else not Has_Abstract_Interfaces (Typ) |
| or else not Build_Thunks |
| then |
| -- No OSD table required |
| |
| Append_To (DT_Aggr_List, |
| New_Reference_To (RTE (RE_Null_Address), Loc)); |
| |
| else |
| OSD_Aggr_List := New_List; |
| |
| declare |
| Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id; |
| Prim : Entity_Id; |
| Prim_Alias : Entity_Id; |
| Prim_Elmt : Elmt_Id; |
| E : Entity_Id; |
| Count : Nat := 0; |
| Pos : Nat; |
| |
| begin |
| Prim_Table := (others => Empty); |
| Prim_Alias := Empty; |
| |
| Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); |
| while Present (Prim_Elmt) loop |
| Prim := Node (Prim_Elmt); |
| |
| if Present (Abstract_Interface_Alias (Prim)) |
| and then Find_Dispatching_Type |
| (Abstract_Interface_Alias (Prim)) = Iface |
| then |
| Prim_Alias := Abstract_Interface_Alias (Prim); |
| |
| E := Prim; |
| while Present (Alias (E)) loop |
| E := Alias (E); |
| end loop; |
| |
| Pos := UI_To_Int (DT_Position (Prim_Alias)); |
| |
| if Present (Prim_Table (Pos)) then |
| pragma Assert (Prim_Table (Pos) = E); |
| null; |
| |
| else |
| Prim_Table (Pos) := E; |
| |
| Append_To (OSD_Aggr_List, |
| Make_Component_Association (Loc, |
| Choices => New_List ( |
| Make_Integer_Literal (Loc, |
| DT_Position (Prim_Alias))), |
| Expression => |
| Make_Integer_Literal (Loc, |
| DT_Position (Alias (Prim))))); |
| |
| Count := Count + 1; |
| end if; |
| end if; |
| |
| Next_Elmt (Prim_Elmt); |
| end loop; |
| pragma Assert (Count = Nb_Prim); |
| end; |
| |
| OSD := Make_Defining_Identifier (Loc, New_Internal_Name ('I')); |
| |
| 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)))), |
| Expression => Make_Aggregate (Loc, |
| Component_Associations => New_List ( |
| Make_Component_Association (Loc, |
| Choices => New_List ( |
| New_Occurrence_Of |
| (RTE_Record_Component (RE_OSD_Num_Prims), Loc)), |
| Expression => |
| Make_Integer_Literal (Loc, Nb_Prim)), |
| |
| Make_Component_Association (Loc, |
| Choices => New_List ( |
| New_Occurrence_Of |
| (RTE_Record_Component (RE_OSD_Table), Loc)), |
| Expression => Make_Aggregate (Loc, |
| Component_Associations => OSD_Aggr_List)))))); |
| |
| Append_To (Result, |
| Make_Attribute_Definition_Clause (Loc, |
| Name => New_Reference_To (OSD, Loc), |
| Chars => Name_Alignment, |
| Expression => |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Reference_To (RTE (RE_Integer_Address), Loc), |
| Attribute_Name => Name_Alignment))); |
| |
| -- In secondary dispatch tables the Typeinfo component contains |
| -- the address of the Object Specific Data (see a-tags.ads) |
| |
| Append_To (DT_Aggr_List, |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Reference_To (OSD, Loc), |
| Attribute_Name => Name_Address)); |
| end if; |
| |
| -- Initialize the table of primitive operations |
| |
| Prim_Ops_Aggr_List := New_List; |
| |
| if Empty_DT then |
| Append_To (Prim_Ops_Aggr_List, |
| New_Reference_To (RTE (RE_Null_Address), Loc)); |
| |
| elsif Is_Abstract_Type (Typ) |
| or else not Building_Static_DT (Typ) |
| then |
| for J in 1 .. Nb_Prim loop |
| Append_To (Prim_Ops_Aggr_List, |
| New_Reference_To (RTE (RE_Null_Address), Loc)); |
| end loop; |
| |
| else |
| declare |
| Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id; |
| Pos : Nat; |
| Thunk_Code : Node_Id; |
| Thunk_Id : Entity_Id; |
| |
| begin |
| Prim_Table := (others => Empty); |
| |
| Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); |
| while Present (Prim_Elmt) loop |
| Prim := Node (Prim_Elmt); |
| |
| if not Is_Predefined_Dispatching_Operation (Prim) |
| and then Present (Abstract_Interface_Alias (Prim)) |
| and then not Is_Abstract_Subprogram (Alias (Prim)) |
| and then not Is_Imported (Alias (Prim)) |
| and then Find_Dispatching_Type |
| (Abstract_Interface_Alias (Prim)) = Iface |
| |
| -- Generate the code of the thunk only if the abstract |
| -- interface type is not an immediate ancestor of |
| -- Tagged_Type; otherwise the DT associated with the |
| -- interface is the primary DT. |
| |
| and then not Is_Parent (Iface, Typ) |
| then |
| if not Build_Thunks then |
| Pos := |
| UI_To_Int |
| (DT_Position (Abstract_Interface_Alias (Prim))); |
| Prim_Table (Pos) := Alias (Prim); |
| else |
| Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code); |
| |
| if Present (Thunk_Id) then |
| Pos := |
| UI_To_Int |
| (DT_Position (Abstract_Interface_Alias (Prim))); |
| |
| Prim_Table (Pos) := Thunk_Id; |
| Append_To (Result, Thunk_Code); |
| end if; |
| end if; |
| end if; |
| |
| Next_Elmt (Prim_Elmt); |
| end loop; |
| |
| for J in Prim_Table'Range loop |
| if Present (Prim_Table (J)) then |
| New_Node := |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Reference_To (Prim_Table (J), Loc), |
| Attribute_Name => Name_Address); |
| else |
| New_Node := |
| New_Reference_To (RTE (RE_Null_Address), Loc); |
| end if; |
| |
| Append_To (Prim_Ops_Aggr_List, New_Node); |
| end loop; |
| end; |
| end if; |
| |
| Append_To (DT_Aggr_List, |
| Make_Aggregate (Loc, |
| Expressions => Prim_Ops_Aggr_List)); |
| |
| 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_Dispatch_Table_Wrapper), Loc), |
| Constraint => Make_Index_Or_Discriminant_Constraint (Loc, |
| Constraints => DT_Constr_List)), |
| |
| Expression => Make_Aggregate (Loc, |
| Expressions => DT_Aggr_List))); |
| |
| 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); |
| |
| Append_To (Result, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Iface_DT_Ptr, |
| Constant_Present => True, |
| Object_Definition => |
| New_Reference_To (RTE (RE_Interface_Tag), Loc), |
| Expression => |
| Unchecked_Convert_To (RTE (RE_Interface_Tag), |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| Make_Selected_Component (Loc, |
| Prefix => New_Reference_To (Iface_DT, Loc), |
| Selector_Name => |
| New_Occurrence_Of |
| (RTE_Record_Component (RE_Prims_Ptr), Loc)), |
| Attribute_Name => Name_Address)))); |
| |
| end Make_Secondary_DT; |
| |
| -- Local variables |
| |
| Elab_Code : constant List_Id := New_List; |
| Result : constant List_Id := New_List; |
| Tname : constant Name_Id := Chars (Typ); |
| AI : Elmt_Id; |
| AI_Tag_Elmt : Elmt_Id; |
| AI_Tag_Comp : Elmt_Id; |
| DT_Aggr_List : List_Id; |
| DT_Constr_List : List_Id; |
| DT_Ptr : Entity_Id; |
| ITable : Node_Id; |
| I_Depth : Nat := 0; |
| Iface_Table_Node : Node_Id; |
| Name_ITable : Name_Id; |
| Name_No_Reg : Name_Id; |
| Nb_Predef_Prims : Nat := 0; |
| Nb_Prim : Nat := 0; |
| New_Node : Node_Id; |
| No_Reg : Node_Id; |
| Null_Parent_Tag : Boolean := False; |
| Num_Ifaces : Nat := 0; |
| Old_Tag1 : Node_Id; |
| Old_Tag2 : Node_Id; |
| Prim : Entity_Id; |
| Prim_Elmt : Elmt_Id; |
| Prim_Ops_Aggr_List : List_Id; |
| Suffix_Index : Int; |
| Typ_Comps : Elist_Id; |
| Typ_Ifaces : Elist_Id; |
| TSD_Aggr_List : List_Id; |
| TSD_Tags_List : List_Id; |
| |
| -- The following name entries are used by Make_DT to generate a number |
| -- of entities related to a tagged type. These entities may be generated |
| -- in a scope other than that of the tagged type declaration, and if |
| -- the entities for two tagged types with the same name happen to be |
| -- generated in the same scope, we have to take care to use different |
| -- names. This is achieved by means of a unique serial number appended |
| -- to each generated entity name. |
| |
| Name_DT : constant Name_Id := |
| New_External_Name (Tname, 'T', Suffix_Index => -1); |
| Name_Exname : constant Name_Id := |
| New_External_Name (Tname, 'E', Suffix_Index => -1); |
| Name_HT_Link : constant Name_Id := |
| New_External_Name (Tname, 'H', Suffix_Index => -1); |
| Name_Predef_Prims : constant Name_Id := |
| New_External_Name (Tname, 'R', Suffix_Index => -1); |
| Name_SSD : constant Name_Id := |
| New_External_Name (Tname, 'S', Suffix_Index => -1); |
| Name_TSD : constant Name_Id := |
| New_External_Name (Tname, 'B', Suffix_Index => -1); |
| |
| -- Entities built with above names |
| |
| DT : constant Entity_Id := |
| Make_Defining_Identifier (Loc, Name_DT); |
| Exname : constant Entity_Id := |
| Make_Defining_Identifier (Loc, Name_Exname); |
| HT_Link : constant Entity_Id := |
| Make_Defining_Identifier (Loc, Name_HT_Link); |
| Predef_Prims : constant Entity_Id := |
| Make_Defining_Identifier (Loc, Name_Predef_Prims); |
| SSD : constant Entity_Id := |
| Make_Defining_Identifier (Loc, Name_SSD); |
| TSD : constant Entity_Id := |
| Make_Defining_Identifier (Loc, Name_TSD); |
| |
| -- Start of processing for Make_DT |
| |
| begin |
| pragma Assert (Is_Frozen (Typ)); |
| |
| -- Handle cases in which there is no need to build the dispatch table |
| |
| if Has_Dispatch_Table (Typ) |
| or else No (Access_Disp_Table (Typ)) |
| or else Is_CPP_Class (Typ) |
| then |
| return Result; |
| |
| elsif No_Run_Time_Mode then |
| Error_Msg_CRT ("tagged types", Typ); |
| return Result; |
| |
| elsif not RTE_Available (RE_Tag) then |
| Append_To (Result, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Node (First_Elmt |
| (Access_Disp_Table (Typ))), |
| Object_Definition => New_Reference_To (RTE (RE_Tag), Loc), |
| Constant_Present => True, |
| Expression => |
| Unchecked_Convert_To (RTE (RE_Tag), |
| New_Reference_To (RTE (RE_Null_Address), Loc)))); |
| |
| Analyze_List (Result, Suppress => All_Checks); |
| Error_Msg_CRT ("tagged types", Typ); |
| return Result; |
| end if; |
| |
| -- Ensure that the value of Max_Predef_Prims defined in a-tags is |
| -- correct. Valid values are 10 under configurable runtime or 16 |
| -- with full runtime. |
| |
| if RTE_Available (RE_Interface_Data) then |
| if Max_Predef_Prims /= 16 then |
| Error_Msg_N ("run-time library configuration error", Typ); |
| return Result; |
| end if; |
| else |
| if Max_Predef_Prims /= 10 then |
| Error_Msg_N ("run-time library configuration error", Typ); |
| Error_Msg_CRT ("tagged types", Typ); |
| return Result; |
| end if; |
| end if; |
| |
| -- Ensure that all the primitives are frozen. This is only required when |
| -- building static dispatch tables --- the primitives must be frozen to |
| -- be referenced (otherwise we have problems with the backend). It is |
| -- not a requirement with nonstatic dispatch tables because in this case |
| -- we generate now an empty dispatch table; the extra code required to |
| -- register the primitives in the slots will be generated later --- when |
| -- each primitive is frozen (see Freeze_Subprogram). |
| |
| if Building_Static_DT (Typ) |
| and then not Is_CPP_Class (Typ) |
| then |
| declare |
| Save : constant Boolean := Freezing_Library_Level_Tagged_Type; |
| Prim_Elmt : Elmt_Id; |
| Frnodes : List_Id; |
| |
| begin |
| Freezing_Library_Level_Tagged_Type := True; |
| Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); |
| while Present (Prim_Elmt) loop |
| Frnodes := Freeze_Entity (Node (Prim_Elmt), Loc); |
| |
| declare |
| Subp : constant Entity_Id := Node (Prim_Elmt); |
| F : Entity_Id; |
| |
| begin |
| F := First_Formal (Subp); |
| while Present (F) loop |
| Check_Premature_Freezing (Subp, Etype (F)); |
| Next_Formal (F); |
| end loop; |
| |
| Check_Premature_Freezing (Subp, Etype (Subp)); |
| end; |
| |
| if Present (Frnodes) then |
| Append_List_To (Result, Frnodes); |
| end if; |
| |
| Next_Elmt (Prim_Elmt); |
| end loop; |
| Freezing_Library_Level_Tagged_Type := Save; |
| end; |
| end if; |
| |
| -- Ada 2005 (AI-251): Build the secondary dispatch tables |
| |
| if Has_Abstract_Interfaces (Typ) then |
| Collect_Interface_Components (Typ, Typ_Comps); |
| |
| Suffix_Index := 0; |
| AI_Tag_Elmt := Next_Elmt (First_Elmt (Access_Disp_Table (Typ))); |
| |
| AI_Tag_Comp := First_Elmt (Typ_Comps); |
| while Present (AI_Tag_Comp) loop |
| |
| -- Build the secondary table containing pointers to thunks |
| |
| Make_Secondary_DT |
| (Typ => Typ, |
| Iface => Base_Type (Related_Type (Node (AI_Tag_Comp))), |
| Num_Iface_Prims => UI_To_Int |
| (DT_Entry_Count (Node (AI_Tag_Comp))), |
| Iface_DT_Ptr => Node (AI_Tag_Elmt), |
| Build_Thunks => True, |
| Result => Result); |
| Next_Elmt (AI_Tag_Elmt); |
| |
| -- Build the secondary table contaning pointers to primitives |
| -- (used to give support to Generic Dispatching Constructors). |
| |
| Make_Secondary_DT |
| (Typ => Typ, |
| Iface => Base_Type (Related_Type (Node (AI_Tag_Comp))), |
| Num_Iface_Prims => UI_To_Int |
| (DT_Entry_Count (Node (AI_Tag_Comp))), |
| Iface_DT_Ptr => Node (AI_Tag_Elmt), |
| Build_Thunks => False, |
| Result => Result); |
| Next_Elmt (AI_Tag_Elmt); |
| |
| Suffix_Index := Suffix_Index + 1; |
| Next_Elmt (AI_Tag_Comp); |
| end loop; |
| end if; |
| |
| -- Get the _tag entity and the number of primitives of its dispatch |
| -- table. |
| |
| DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); |
| Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ))); |
| |
| Set_Is_Statically_Allocated (DT); |
| Set_Is_Statically_Allocated (SSD); |
| Set_Is_Statically_Allocated (TSD); |
| Set_Is_Statically_Allocated (Predef_Prims); |
| |
| -- Generate code to define the boolean that controls registration, in |
| -- order to avoid multiple registrations for tagged types defined in |
| -- multiple-called scopes. |
| |
| Name_No_Reg := New_External_Name (Tname, 'F', Suffix_Index => -1); |
| No_Reg := Make_Defining_Identifier (Loc, Name_No_Reg); |
| |
| Set_Ekind (No_Reg, E_Variable); |
| Set_Is_Statically_Allocated (No_Reg); |
| |
| 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))); |
| |
| -- In case of locally defined tagged type we declare the object |
| -- contanining the dispatch table by means of a variable. Its |
| -- initialization is done later by means of an assignment. This is |
| -- required to generate its External_Tag. |
| |
| if not Building_Static_DT (Typ) then |
| |
| -- Generate: |
| -- DT : No_Dispatch_Table_Wrapper; |
| -- for DT'Alignment use Address'Alignment; |
| -- DT_Ptr : Tag := !Tag (DT.NDT_Prims_Ptr'Address); |
| |
| if not Has_DT (Typ) then |
| Append_To (Result, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => DT, |
| Aliased_Present => True, |
| Constant_Present => False, |
| Object_Definition => |
| New_Reference_To |
| (RTE (RE_No_Dispatch_Table_Wrapper), Loc))); |
| |
| 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))); |
| |
| Append_To (Result, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => DT_Ptr, |
| Object_Definition => New_Reference_To (RTE (RE_Tag), Loc), |
| Constant_Present => True, |
| Expression => |
| Unchecked_Convert_To (RTE (RE_Tag), |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| Make_Selected_Component (Loc, |
| Prefix => New_Reference_To (DT, Loc), |
| Selector_Name => |
| New_Occurrence_Of |
| (RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)), |
| Attribute_Name => Name_Address)))); |
| |
| -- Generate: |
| -- DT : Dispatch_Table_Wrapper (Nb_Prim); |
| -- for DT'Alignment use Address'Alignment; |
| -- DT_Ptr : Tag := !Tag (DT.Prims_Ptr'Address); |
| |
| else |
| -- If the tagged type has no primitives we add a dummy slot |
| -- whose address will be the tag of this type. |
| |
| if Nb_Prim = 0 then |
| DT_Constr_List := |
| New_List (Make_Integer_Literal (Loc, 1)); |
| else |
| DT_Constr_List := |
| New_List (Make_Integer_Literal (Loc, Nb_Prim)); |
| end if; |
| |
| Append_To (Result, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => DT, |
| Aliased_Present => True, |
| Constant_Present => False, |
| Object_Definition => |
| Make_Subtype_Indication (Loc, |
| Subtype_Mark => |
| New_Reference_To (RTE (RE_Dispatch_Table_Wrapper), Loc), |
| Constraint => Make_Index_Or_Discriminant_Constraint (Loc, |
| Constraints => DT_Constr_List)))); |
| |
| 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))); |
| |
| Append_To (Result, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => DT_Ptr, |
| Object_Definition => New_Reference_To (RTE (RE_Tag), Loc), |
| Constant_Present => True, |
| Expression => |
| Unchecked_Convert_To (RTE (RE_Tag), |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| Make_Selected_Component (Loc, |
| Prefix => New_Reference_To (DT, Loc), |
| Selector_Name => |
| New_Occurrence_Of |
| (RTE_Record_Component (RE_Prims_Ptr), Loc)), |
| Attribute_Name => Name_Address)))); |
| 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))))); |
| |
| Set_Is_Statically_Allocated (Exname); |
| Set_Is_True_Constant (Exname); |
| |
| -- Declare the object used by Ada.Tags.Register_Tag |
| |
| if RTE_Available (RE_Register_Tag) then |
| Append_To (Result, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => HT_Link, |
| Object_Definition => New_Reference_To (RTE (RE_Tag), Loc))); |
| end if; |
| |
| -- 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 : Type_Specific_Data (I_Depth) := |
| -- (Idepth => I_Depth, |
| -- Access_Level => Type_Access_Level (Typ), |
| -- Expanded_Name => Cstring_Ptr!(Exname'Address)) |
| -- External_Tag => Cstring_Ptr!(Exname'Address)) |
| -- HT_Link => HT_Link'Address, |
| -- Transportable => <<boolean-value>>, |
| -- RC_Offset => <<integer-value>>, |
| -- [ Interfaces_Table => <<access-value>> ] |
| -- [ SSD => SSD_Table'Address ] |
| -- Tags_Table => (0 => null, |
| -- 1 => Parent'Tag |
| -- ...); |
| -- for TSD'Alignment use Address'Alignment |
| |
| TSD_Aggr_List := New_List; |
| |
| -- Idepth: 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 |
| Current_Typ : Entity_Id; |
| Parent_Typ : Entity_Id; |
| |
| begin |
| I_Depth := 0; |
| Current_Typ := Typ; |
| loop |
| Parent_Typ := Etype (Current_Typ); |
| |
| if Is_Private_Type (Parent_Typ) then |
| Parent_Typ := Full_View (Base_Type (Parent_Typ)); |
| end if; |
| |
| exit when Parent_Typ = Current_Typ; |
| |
| I_Depth := I_Depth + 1; |
| Current_Typ := Parent_Typ; |
| end loop; |
| end; |
| |
| Append_To (TSD_Aggr_List, |
| Make_Integer_Literal (Loc, I_Depth)); |
| |
| -- Access_Level |
| |
| Append_To (TSD_Aggr_List, |
| Make_Integer_Literal (Loc, Type_Access_Level (Typ))); |
| |
| -- Expanded_Name |
| |
| Append_To (TSD_Aggr_List, |
| Unchecked_Convert_To (RTE (RE_Cstring_Ptr), |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Reference_To (Exname, Loc), |
| Attribute_Name => Name_Address))); |
| |
| -- External_Tag of a local tagged type |
| |
| -- <typ>A : constant String := |
| -- "Internal tag at 16#tag-addr#: <full-name-of-typ>"; |
| |
| -- The reason we generate this strange name is that we do not want to |
| -- enter local tagged types in the global hash table used to compute |
| -- the Internal_Tag attribute for two reasons: |
| |
| -- 1. It is hard to avoid a tasking race condition for entering the |
| -- entry into the hash table. |
| |
| -- 2. It would cause a storage leak, unless we rig up considerable |
| -- mechanism to remove the entry from the hash table on exit. |
| |
| -- So what we do is to generate the above external tag name, where the |
| -- hex address is the address of the local dispatch table (i.e. exactly |
| -- the value we want if Internal_Tag is computed from this string). |
| |
| -- Of course this value will only be valid if the tagged type is still |
| -- in scope, but it clearly must be erroneous to compute the internal |
| -- tag of a tagged type that is out of scope! |
| |
| -- We don't do this processing if an explicit external tag has been |
| -- specified. That's an odd case for which we have already issued a |
| -- warning, where we will not be able to compute the internal tag. |
| |
| if not Is_Library_Level_Entity (Typ) |
| and then not Has_External_Tag_Rep_Clause (Typ) |
| then |
| declare |
| Exname : constant Entity_Id := |
| Make_Defining_Identifier (Loc, |
| New_External_Name (Tname, 'A')); |
| |
| Full_Name : constant String_Id := |
| Full_Qualified_Name (First_Subtype (Typ)); |
| Str1_Id : String_Id; |
| Str2_Id : String_Id; |
| |
| begin |
| -- Generate: |
| -- Str1 = "Internal tag at 16#"; |
| |
| Start_String; |
| Store_String_Chars ("Internal tag at 16#"); |
| Str1_Id := End_String; |
| |
| -- Generate: |
| -- Str2 = "#: <type-full-name>"; |
| |
| Start_String; |
| Store_String_Chars ("#: "); |
| Store_String_Chars (Full_Name); |
| Str2_Id := End_String; |
| |
| -- Generate: |
| -- Exname : constant String := |
| -- Str1 & Address_Image (Tag) & Str2; |
| |
| if RTE_Available (RE_Address_Image) then |
| Append_To (Result, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Exname, |
| Constant_Present => True, |
| Object_Definition => New_Reference_To |
| (Standard_String, Loc), |
| Expression => |
| Make_Op_Concat (Loc, |
| Left_Opnd => |
| Make_String_Literal (Loc, Str1_Id), |
| Right_Opnd => |
| Make_Op_Concat (Loc, |
| Left_Opnd => |
| Make_Function_Call (Loc, |
| Name => |
| New_Reference_To |
| (RTE (RE_Address_Image), Loc), |
| Parameter_Associations => New_List ( |
| Unchecked_Convert_To (RTE (RE_Address), |
| New_Reference_To (DT_Ptr, Loc)))), |
| Right_Opnd => |
| Make_String_Literal (Loc, Str2_Id))))); |
| |
| else |
| Append_To (Result, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Exname, |
| Constant_Present => True, |
| Object_Definition => New_Reference_To |
| (Standard_String, Loc), |
| Expression => |
| Make_Op_Concat (Loc, |
| Left_Opnd => |
| Make_String_Literal (Loc, Str1_Id), |
| Right_Opnd => |
| Make_String_Literal (Loc, Str2_Id)))); |
| end if; |
| |
| New_Node := |
| Unchecked_Convert_To (RTE (RE_Cstring_Ptr), |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Reference_To (Exname, Loc), |
| Attribute_Name => Name_Address)); |
| end; |
| |
| -- External tag of a library-level tagged type: Check for a definition |
| -- of External_Tag. The clause is considered only if it applies to this |
| -- specific tagged type, as opposed to one of its ancestors. |
| |
| else |
| declare |
| Def : constant Node_Id := Get_Attribute_Definition_Clause (Typ, |
| Attribute_External_Tag); |
| Old_Val : String_Id; |
| New_Val : String_Id; |
| E : Entity_Id; |
| |
| begin |
| if not Present (Def) |
| or else Entity (Name (Def)) /= Typ |
| then |
| New_Node := |
| Unchecked_Convert_To (RTE (RE_Cstring_Ptr), |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Reference_To (Exname, Loc), |
| Attribute_Name => Name_Address)); |
| else |
| Old_Val := Strval (Expr_Value_S (Expression (Def))); |
| |
| -- For the rep clause "for <typ>'external_tag use y" generate: |
| |
| -- <typ>A : constant string := y; |
| -- |
| -- <typ>A'Address is used to set the External_Tag component |
| -- of the TSD |
| |
| -- Create a new nul terminated string if it is not already |
| |
| if String_Length (Old_Val) > 0 |
| and then |
| Get_String_Char (Old_Val, String_Length (Old_Val)) = 0 |
| then |
| New_Val := Old_Val; |
| else |
| Start_String (Old_Val); |
| Store_String_Char (Get_Char_Code (ASCII.NUL)); |
| New_Val := End_String; |
| end if; |
| |
| E := Make_Defining_Identifier (Loc, |
| New_External_Name (Chars (Typ), 'A')); |
| |
| Append_To (Result, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => E, |
| Constant_Present => True, |
| Object_Definition => |
| New_Reference_To (Standard_String, Loc), |
| Expression => |
| Make_String_Literal (Loc, New_Val))); |
| |
| New_Node := |
| Unchecked_Convert_To (RTE (RE_Cstring_Ptr), |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Reference_To (E, Loc), |
| Attribute_Name => Name_Address)); |
| end if; |
| end; |
| end if; |
| |
| Append_To (TSD_Aggr_List, New_Node); |
| |
| -- HT_Link |
| |
| if RTE_Available (RE_Register_Tag) then |
| Append_To (TSD_Aggr_List, |
| Unchecked_Convert_To (RTE (RE_Tag_Ptr), |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Reference_To (HT_Link, Loc), |
| Attribute_Name => Name_Address))); |
| else |
| Append_To (TSD_Aggr_List, |
| Unchecked_Convert_To (RTE (RE_Tag_Ptr), |
| New_Reference_To (RTE (RE_Null_Address), Loc))); |
| end if; |
| |
| -- Transportable: Set for types that can be used in remote calls |
| -- with respect to E.4(18) legality rules. |
| |
| declare |
| Transportable : Entity_Id; |
| |
| begin |
| Transportable := |
| 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 (TSD_Aggr_List, |
| New_Occurrence_Of (Transportable, Loc)); |
| end; |
| |
| -- RC_Offset: These are the valid values and their meaning: |
| |
| -- >0: For simple types with controlled components is |
| -- type._record_controller'position |
| |
| -- 0: For types with no controlled components |
| |
| -- -1: For complex types with controlled components where the position |
| -- of the record controller is not statically computable but there |
| -- are controlled components at this level. The _Controller field |
| -- is available right after the _parent. |
| |
| -- -2: There are no controlled components at this level. We need to |
| -- get the position from the parent. |
| |
| declare |
| RC_Offset_Node : Node_Id; |
| Parent_Typ : Entity_Id; |
| |
| begin |
| if Present (Full_View (Etype (Typ))) then |
| Parent_Typ := Full_View (Etype (Typ)); |
| else |
| Parent_Typ := Etype (Typ); |
| end if; |
| |
| if not Has_Controlled_Component (Typ) then |
| RC_Offset_Node := Make_Integer_Literal (Loc, 0); |
| |
| elsif Etype (Typ) /= Typ |
| and then Has_Discriminants (Parent_Typ) |
| then |
| if Has_New_Controlled_Component (Typ) then |
| RC_Offset_Node := Make_Integer_Literal (Loc, -1); |
| else |
| RC_Offset_Node := Make_Integer_Literal (Loc, -2); |
| end if; |
| else |
| RC_Offset_Node := |
| 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 (RC_Offset_Node); |
| Set_Etype (Prefix (RC_Offset_Node), RTE (RE_Record_Controller)); |
| Set_Etype (Prefix (Prefix (RC_Offset_Node)), Typ); |
| Set_Etype (Selector_Name (Prefix (RC_Offset_Node)), |
| RTE (RE_Record_Controller)); |
| Set_Etype (RC_Offset_Node, RTE (RE_Storage_Offset)); |
| end if; |
| |
| Append_To (TSD_Aggr_List, RC_Offset_Node); |
| end; |
| |
| -- Interfaces_Table (required for AI-405) |
| |
| if RTE_Record_Component_Available (RE_Interfaces_Table) then |
| |
| -- Count the number of interface types implemented by Typ |
| |
| Collect_Abstract_Interfaces (Typ, Typ_Ifaces); |
| |
| AI := First_Elmt (Typ_Ifaces); |
| while Present (AI) loop |
| Num_Ifaces := Num_Ifaces + 1; |
| Next_Elmt (AI); |
| end loop; |
| |
| if Num_Ifaces = 0 then |
| Iface_Table_Node := Make_Null (Loc); |
| |
| -- Generate the Interface_Table object |
| |
| else |
| declare |
| TSD_Ifaces_List : constant List_Id := New_List; |
| Elmt : Elmt_Id; |
| Sec_DT_Tag : Node_Id; |
| |
| begin |
| AI := First_Elmt (Typ_Ifaces); |
| while Present (AI) loop |
| if Is_Parent (Node (AI), Typ) then |
| Sec_DT_Tag := |
| New_Reference_To (DT_Ptr, Loc); |
| else |
| Elmt := Next_Elmt (First_Elmt (Access_Disp_Table (Typ))); |
| pragma Assert (Has_Thunks (Node (Elmt))); |
| |
| while Ekind (Node (Elmt)) = E_Constant |
| and then not |
| Is_Parent (Node (AI), Related_Type (Node (Elmt))) |
| loop |
| pragma Assert (Has_Thunks (Node (Elmt))); |
| Next_Elmt (Elmt); |
| pragma Assert (not Has_Thunks (Node (Elmt))); |
| Next_Elmt (Elmt); |
| end loop; |
| |
| pragma Assert (Ekind (Node (Elmt)) = E_Constant |
| and then not Has_Thunks (Node (Next_Elmt (Elmt)))); |
| Sec_DT_Tag := |
| New_Reference_To (Node (Next_Elmt (Elmt)), Loc); |
| end if; |
| |
| Append_To (TSD_Ifaces_List, |
| Make_Aggregate (Loc, |
| Expressions => New_List ( |
| |
| -- Iface_Tag |
| |
| Unchecked_Convert_To (RTE (RE_Tag), |
| New_Reference_To |
| (Node (First_Elmt (Access_Disp_Table (Node (AI)))), |
| Loc)), |
| |
| -- Static_Offset_To_Top |
| |
| New_Reference_To (Standard_True, Loc), |
| |
| -- Offset_To_Top_Value |
| |
| Make_Integer_Literal (Loc, 0), |
| |
| -- Offset_To_Top_Func |
| |
| Make_Null (Loc), |
| |
| -- Secondary_DT |
| |
| Unchecked_Convert_To (RTE (RE_Tag), Sec_DT_Tag) |
| |
| ))); |
| |
| Next_Elmt (AI); |
| end loop; |
| |
| Name_ITable := New_External_Name (Tname, 'I'); |
| ITable := Make_Defining_Identifier (Loc, Name_ITable); |
| Set_Is_Statically_Allocated (ITable); |
| |
| -- The table of interfaces is not constant; its slots are |
| -- filled at run-time by the IP routine using attribute |
| -- 'Position to know the location of the tag components |
| -- (and this attribute cannot be safely used before the |
| -- object is initialized). |
| |
| Append_To (Result, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => ITable, |
| Aliased_Present => True, |
| Constant_Present => False, |
| 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)))), |
| |
| Expression => Make_Aggregate (Loc, |
| Expressions => New_List ( |
| Make_Integer_Literal (Loc, Num_Ifaces), |
| Make_Aggregate (Loc, |
| Expressions => TSD_Ifaces_List))))); |
| |
| Append_To (Result, |
| Make_Attribute_Definition_Clause (Loc, |
| Name => New_Reference_To (ITable, Loc), |
| Chars => Name_Alignment, |
| Expression => |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Reference_To (RTE (RE_Integer_Address), Loc), |
| Attribute_Name => Name_Alignment))); |
| |
| Iface_Table_Node := |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Reference_To (ITable, Loc), |
| Attribute_Name => Name_Unchecked_Access); |
| end; |
| end if; |
| |
| Append_To (TSD_Aggr_List, Iface_Table_Node); |
| end if; |
| |
| -- Generate the Select Specific Data table for synchronized types that |
| -- implement synchronized interfaces. The size of the table is |
| -- constrained by the number of non-predefined primitive operations. |
| |
| if RTE_Record_Component_Available (RE_SSD) then |
| if Ada_Version >= Ada_05 |
| and then Has_DT (Typ) |
| and then Is_Concurrent_Record_Type (Typ) |
| and then Has_Abstract_Interfaces (Typ) |
| and then Nb_Prim > 0 |
| and then not Is_Abstract_Type (Typ) |
| and then not Is_Controlled (Typ) |
| and then not Restriction_Active (No_Dispatching_Calls) |
| 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)))))); |
| |
| Append_To (Result, |
| Make_Attribute_Definition_Clause (Loc, |
| Name => New_Reference_To (SSD, Loc), |
| Chars => Name_Alignment, |
| Expression => |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Reference_To (RTE (RE_Integer_Address), Loc), |
| Attribute_Name => Name_Alignment))); |
| |
| -- This table is initialized by Make_Select_Specific_Data_Table, |
| -- which calls Set_Entry_Index and Set_Prim_Op_Kind. |
| |
| Append_To (TSD_Aggr_List, |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Reference_To (SSD, Loc), |
| Attribute_Name => Name_Unchecked_Access)); |
| else |
| Append_To (TSD_Aggr_List, Make_Null (Loc)); |
| end if; |
| end if; |
| |
| -- Initialize the table of ancestor tags. In case of interface types |
| -- this table is not needed. |
| |
| declare |
| Current_Typ : Entity_Id; |
| Parent_Typ : Entity_Id; |
| Pos : Nat; |
| |
| begin |
| TSD_Tags_List := New_List; |
| |
| -- If we are not statically allocating the dispatch table then we |
| -- must fill position 0 with null because we still have not |
| -- generated the tag of Typ. |
| |
| if not Building_Static_DT (Typ) |
| or else Is_Interface (Typ) |
| then |
| Append_To (TSD_Tags_List, |
| Unchecked_Convert_To (RTE (RE_Tag), |
| New_Reference_To (RTE (RE_Null_Address), Loc))); |
| |
| -- Otherwise we can safely reference the tag |
| |
| else |
| Append_To (TSD_Tags_List, |
| New_Reference_To (DT_Ptr, Loc)); |
| end if; |
| |
| -- Fill the rest of the table with the tags of the ancestors |
| |
| Pos := 1; |
| Current_Typ := Typ; |
| |
| loop |
| Parent_Typ := Etype (Current_Typ); |
| |
| if Is_Private_Type (Parent_Typ) then |
| Parent_Typ := Full_View (Base_Type (Parent_Typ)); |
| end if; |
| |
| exit when Parent_Typ = Current_Typ; |
| |
| if Is_CPP_Class (Parent_Typ) |
| or else Is_Interface (Typ) |
| then |
| -- The tags defined in the C++ side will be inherited when |
| -- the object is constructed (Exp_Ch3.Build_Init_Procedure) |
| |
| Append_To (TSD_Tags_List, |
| Unchecked_Convert_To (RTE (RE_Tag), |
| New_Reference_To (RTE (RE_Null_Address), Loc))); |
| else |
| Append_To (TSD_Tags_List, |
| New_Reference_To |
| (Node (First_Elmt (Access_Disp_Table (Parent_Typ))), |
| Loc)); |
| end if; |
| |
| Pos := Pos + 1; |
| Current_Typ := Parent_Typ; |
| end loop; |
| |
| pragma Assert (Pos = I_Depth + 1); |
| end; |
| |
| Append_To (TSD_Aggr_List, |
| Make_Aggregate (Loc, |
| Expressions => TSD_Tags_List)); |
| |
| -- Build the TSD object |
| |
| Append_To (Result, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => TSD, |
| Aliased_Present => True, |
| Constant_Present => Building_Static_DT (Typ), |
| Object_Definition => |
| Make_Subtype_Indication (Loc, |
| Subtype_Mark => New_Reference_To ( |
| RTE (RE_Type_Specific_Data), Loc), |
| Constraint => |
| Make_Index_Or_Discriminant_Constraint (Loc, |
| Constraints => New_List ( |
| Make_Integer_Literal (Loc, I_Depth)))), |
| |
| Expression => Make_Aggregate (Loc, |
| Expressions => TSD_Aggr_List))); |
| |
| Set_Is_True_Constant (TSD, Building_Static_DT (Typ)); |
| |
| 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))); |
| |
| -- Initialize or declare the dispatch table object |
| |
| if not Has_DT (Typ) then |
| DT_Constr_List := New_List; |
| DT_Aggr_List := New_List; |
| |
| -- Typeinfo |
| |
| New_Node := |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Reference_To (TSD, Loc), |
| Attribute_Name => Name_Address); |
| |
| Append_To (DT_Constr_List, New_Node); |
| Append_To (DT_Aggr_List, New_Copy (New_Node)); |
| Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0)); |
| |
| -- In case of locally defined tagged types we have already declared |
| -- and uninitialized object for the dispatch table, which is now |
| -- initialized by means of the following assignment: |
| |
| -- DT := (TSD'Address, 0); |
| |
| if not Building_Static_DT (Typ) then |
| Append_To (Result, |
| Make_Assignment_Statement (Loc, |
| Name => New_Reference_To (DT, Loc), |
| Expression => Make_Aggregate (Loc, |
| Expressions => DT_Aggr_List))); |
| |
| -- In case of library level tagged types we declare and export now |
| -- the constant object containing the dummy dispatch table. There |
| -- is no need to declare the tag here because it has been previously |
| -- declared by Make_Tags |
| |
| -- DT : aliased constant No_Dispatch_Table := |
| -- (NDT_TSD => TSD'Address; |
| -- NDT_Prims_Ptr => 0); |
| -- for DT'Alignment use Address'Alignment; |
| |
| else |
| Append_To (Result, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => DT, |
| Aliased_Present => True, |
| Constant_Present => True, |
| Object_Definition => |
| New_Reference_To (RTE (RE_No_Dispatch_Table_Wrapper), Loc), |
| Expression => Make_Aggregate (Loc, |
| Expressions => DT_Aggr_List))); |
| |
| 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))); |
| |
| Export_DT (Typ, DT); |
| end if; |
| |
| -- Common case: Typ has a dispatch table |
| |
| -- Generate: |
| |
| -- Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) := |
| -- (predef-prim-op-1'address, |
| -- predef-prim-op-2'address, |
| -- ... |
| -- predef-prim-op-n'address); |
| -- for Predef_Prims'Alignment use Address'Alignment |
| |
| -- DT : Dispatch_Table (Nb_Prims) := |
| -- (Signature => <sig-value>, |
| -- Tag_Kind => <tag_kind-value>, |
| -- Predef_Prims => Predef_Prims'First'Address, |
| -- Offset_To_Top => 0, |
| -- TSD => TSD'Address; |
| -- Prims_Ptr => (prim-op-1'address, |
| -- prim-op-2'address, |
| -- ... |
| -- prim-op-n'address)); |
| -- for DT'Alignment use Address'Alignment |
| |
| else |
| declare |
| Pos : Nat; |
| |
| begin |
| if not Building_Static_DT (Typ) then |
| Nb_Predef_Prims := Max_Predef_Prims; |
| |
| else |
| Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); |
| while Present (Prim_Elmt) loop |
| Prim := Node (Prim_Elmt); |
| |
| if Is_Predefined_Dispatching_Operation (Prim) |
| and then not Is_Abstract_Subprogram (Prim) |
| then |
| Pos := UI_To_Int (DT_Position (Prim)); |
| |
| if Pos > Nb_Predef_Prims then |
| Nb_Predef_Prims := Pos; |
| end if; |
| end if; |
| |
| Next_Elmt (Prim_Elmt); |
| end loop; |
| end if; |
| |
| declare |
| Prim_Table : array |
| (Nat range 1 .. Nb_Predef_Prims) of Entity_Id; |
| E : Entity_Id; |
| |
| begin |
| Prim_Ops_Aggr_List := New_List; |
| |
| Prim_Table := (others => Empty); |
| |
| if Building_Static_DT (Typ) then |
| Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); |
| while Present (Prim_Elmt) loop |
| Prim := Node (Prim_Elmt); |
| |
| if Is_Predefined_Dispatching_Operation (Prim) |
| and then not Is_Abstract_Subprogram (Prim) |
| and then not Present (Prim_Table |
| (UI_To_Int (DT_Position (Prim)))) |
| then |
| E := Prim; |
| while Present (Alias (E)) loop |
| E := Alias (E); |
| end loop; |
| |
| pragma Assert (not Is_Abstract_Subprogram (E)); |
| Prim_Table (UI_To_Int (DT_Position (Prim))) := E; |
| end if; |
| |
| Next_Elmt (Prim_Elmt); |
| end loop; |
| end if; |
| |
| for J in Prim_Table'Range loop |
| if Present (Prim_Table (J)) then |
| New_Node := |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Reference_To (Prim_Table (J), Loc), |
| Attribute_Name => Name_Address); |
| else |
| New_Node := New_Reference_To (RTE (RE_Null_Address), Loc); |
| end if; |
| |
| Append_To (Prim_Ops_Aggr_List, New_Node); |
| end loop; |
| |
| Append_To (Result, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Predef_Prims, |
| Aliased_Present => True, |
| Constant_Present => Building_Static_DT (Typ), |
| Object_Definition => |
| New_Reference_To (RTE (RE_Address_Array), Loc), |
| Expression => Make_Aggregate (Loc, |
| Expressions => Prim_Ops_Aggr_List))); |
| |
| Append_To (Result, |
| Make_Attribute_Definition_Clause (Loc, |
| Name => New_Reference_To (Predef_Prims, Loc), |
| Chars => Name_Alignment, |
| Expression => |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Reference_To (RTE (RE_Integer_Address), Loc), |
| Attribute_Name => Name_Alignment))); |
| end; |
| end; |
| |
| -- Stage 1: Initialize the discriminant and the record components |
| |
| DT_Constr_List := New_List; |
| DT_Aggr_List := New_List; |
| |
| -- Num_Prims. If the tagged type has no primitives we add a dummy |
| -- slot whose address will be the tag of this type. |
| |
| if Nb_Prim = 0 then |
| New_Node := Make_Integer_Literal (Loc, 1); |
| else |
| New_Node := Make_Integer_Literal (Loc, Nb_Prim); |
| end if; |
| |
| Append_To (DT_Constr_List, New_Node); |
| Append_To (DT_Aggr_List, New_Copy (New_Node)); |
| |
| -- Signature |
| |
| if RTE_Record_Component_Available (RE_Signature) then |
| Append_To (DT_Aggr_List, |
| New_Reference_To (RTE (RE_Primary_DT), Loc)); |
| end if; |
| |
| -- Tag_Kind |
| |
| if RTE_Record_Component_Available (RE_Tag_Kind) then |
| Append_To (DT_Aggr_List, Tagged_Kind (Typ)); |
| end if; |
| |
| -- Predef_Prims |
| |
| Append_To (DT_Aggr_List, |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Reference_To (Predef_Prims, Loc), |
| Attribute_Name => Name_Address)); |
| |
| -- Offset_To_Top |
| |
| if RTE_Record_Component_Available (RE_Offset_To_Top) then |
| Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0)); |
| end if; |
| |
| -- Typeinfo |
| |
| Append_To (DT_Aggr_List, |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Reference_To (TSD, Loc), |
| Attribute_Name => Name_Address)); |
| |
| -- Stage 2: Initialize the table of primitive operations |
| |
| Prim_Ops_Aggr_List := New_List; |
| |
| if Nb_Prim = 0 then |
| Append_To (Prim_Ops_Aggr_List, |
| New_Reference_To (RTE (RE_Null_Address), Loc)); |
| |
| elsif not Building_Static_DT (Typ) then |
| for J in 1 .. Nb_Prim loop |
| Append_To (Prim_Ops_Aggr_List, |
| New_Reference_To (RTE (RE_Null_Address), Loc)); |
| end loop; |
| |
| else |
| declare |
| Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id; |
| E : Entity_Id; |
| Prim : Entity_Id; |
| Prim_Elmt : Elmt_Id; |
| |
| begin |
| Prim_Table := (others => Empty); |
| |
| Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); |
| while Present (Prim_Elmt) loop |
| Prim := Node (Prim_Elmt); |
| |
| if Is_Imported (Prim) |
| or else Present (Abstract_Interface_Alias (Prim)) |
| or else Is_Predefined_Dispatching_Operation (Prim) |
| then |
| null; |
| |
| else |
| -- Traverse the list of aliased entities to handle |
| -- renamings of predefined primitives. |
| |
| E := Prim; |
| while Present (Alias (E)) loop |
| E := Alias (E); |
| end loop; |
| |
| if not Is_Predefined_Dispatching_Operation (E) |
| and then not Is_Abstract_Subprogram (E) |
| and then not Present (Abstract_Interface_Alias (E)) |
| then |
| pragma Assert |
| (UI_To_Int (DT_Position (Prim)) <= Nb_Prim); |
| |
| Prim_Table (UI_To_Int (DT_Position (Prim))) := E; |
| end if; |
| end if; |
| |
| Next_Elmt (Prim_Elmt); |
| end loop; |
| |
| for J in Prim_Table'Range loop |
| if Present (Prim_Table (J)) then |
| New_Node := |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Reference_To (Prim_Table (J), Loc), |
| Attribute_Name => Name_Address); |
| else |
| New_Node := New_Reference_To (RTE (RE_Null_Address), Loc); |
| end if; |
| |
| Append_To (Prim_Ops_Aggr_List, New_Node); |
| end loop; |
| end; |
| end if; |
| |
| Append_To (DT_Aggr_List, |
| Make_Aggregate (Loc, |
| Expressions => Prim_Ops_Aggr_List)); |
| |
| -- In case of locally defined tagged types we have already declared |
| -- and uninitialized object for the dispatch table, which is now |
| -- initialized by means of an assignment. |
| |
| if not Building_Static_DT (Typ) then |
| Append_To (Result, |
| Make_Assignment_Statement (Loc, |
| Name => New_Reference_To (DT, Loc), |
| Expression => Make_Aggregate (Loc, |
| Expressions => DT_Aggr_List))); |
| |
| -- In case of library level tagged types we declare now and export |
| -- the constant object containing the dispatch table. |
| |
| else |
| Append_To (Result, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => DT, |
| Aliased_Present => True, |
| Constant_Present => True, |
| Object_Definition => |
| Make_Subtype_Indication (Loc, |
| Subtype_Mark => New_Reference_To |
| (RTE (RE_Dispatch_Table_Wrapper), Loc), |
| Constraint => Make_Index_Or_Discriminant_Constraint (Loc, |
| Constraints => DT_Constr_List)), |
| Expression => Make_Aggregate (Loc, |
| Expressions => DT_Aggr_List))); |
| |
| 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))); |
| |
| Export_DT (Typ, DT); |
| end if; |
| end if; |
| |
| -- Initialize the table of ancestor tags |
| |
| if not Building_Static_DT (Typ) |
| and then not Is_Interface (Typ) |
| and then not Is_CPP_Class (Typ) |
| then |
| Append_To (Result, |
| Make_Assignment_Statement (Loc, |
| Name => |
| Make_Indexed_Component (Loc, |
| Prefix => |
| Make_Selected_Component (Loc, |
| Prefix => |
| New_Reference_To (TSD, Loc), |
| Selector_Name => |
| New_Reference_To |
| (RTE_Record_Component (RE_Tags_Table), Loc)), |
| Expressions => |
| New_List (Make_Integer_Literal (Loc, 0))), |
| |
| Expression => |
| New_Reference_To |
| (Node (First_Elmt (Access_Disp_Table (Typ))), Loc))); |
| end if; |
| |
| if Building_Static_DT (Typ) then |
| null; |
| |
| -- If the ancestor is a CPP_Class type we inherit the dispatch tables |
| -- in the init proc, and we don't need to fill them in here. |
| |
| elsif Is_CPP_Class (Etype (Typ)) then |
| null; |
| |
| -- Otherwise we fill in the dispatch tables here |
| |
| else |
| if Typ = Etype (Typ) |
| or else Is_CPP_Class (Etype (Typ)) |
| or else Is_Interface (Typ) |
| then |
| Null_Parent_Tag := True; |
| |
| Old_Tag1 := |
| Unchecked_Convert_To (RTE (RE_Tag), |
| Make_Integer_Literal (Loc, 0)); |
| Old_Tag2 := |
| Unchecked_Convert_To (RTE (RE_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 |
| -- Inherit the dispatch table |
| |
| if not Is_Interface (Etype (Typ)) then |
| if not Null_Parent_Tag then |
| declare |
| Nb_Prims : constant Int := |
| UI_To_Int (DT_Entry_Count |
| (First_Tag_Component (Etype (Typ)))); |
| begin |
| Append_To (Elab_Code, |
| Build_Inherit_Predefined_Prims (Loc, |
| Old_Tag_Node => Old_Tag1, |
| New_Tag_Node => |
| New_Reference_To (DT_Ptr, Loc))); |
| |
| if Nb_Prims /= 0 then |
| Append_To (Elab_Code, |
| Build_Inherit_Prims (Loc, |
| Typ => Typ, |
| Old_Tag_Node => Old_Tag2, |
| New_Tag_Node => New_Reference_To (DT_Ptr, Loc), |
| Num_Prims => Nb_Prims)); |
| end if; |
| end; |
| end if; |
| end if; |
| |
| -- Inherit the secondary dispatch tables of the ancestor |
| |
| if not Is_CPP_Class (Etype (Typ)) then |
| declare |
| Sec_DT_Ancestor : Elmt_Id := |
| Next_Elmt |
| (First_Elmt |
| (Access_Disp_Table (Etype (Typ)))); |
| Sec_DT_Typ : Elmt_Id := |
| Next_Elmt |
| (First_Elmt |
| (Access_Disp_Table (Typ))); |
| |
| procedure Copy_Secondary_DTs (Typ : Entity_Id); |
| -- Local procedure required to climb through the ancestors |
| -- and copy the contents of all their secondary dispatch |
| -- tables. |
| |
| ------------------------ |
| -- Copy_Secondary_DTs -- |
| ------------------------ |
| |
| procedure Copy_Secondary_DTs (Typ : Entity_Id) is |
| E : Entity_Id; |
| 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)) |
| and then Ekind (Node (Sec_DT_Ancestor)) = E_Constant |
| loop |
| if Is_Tag (E) and then Chars (E) /= Name_uTag then |
| declare |
| Num_Prims : constant Int := |
| UI_To_Int (DT_Entry_Count (E)); |
| |
| begin |
| if not Is_Interface (Etype (Typ)) then |
| |
| -- Inherit first secondary dispatch table |
| |
| Append_To (Elab_Code, |
| Build_Inherit_Predefined_Prims (Loc, |
| Old_Tag_Node => |
| Unchecked_Convert_To (RTE (RE_Tag), |
| New_Reference_To |
| (Node (Sec_DT_Ancestor), Loc)), |
| New_Tag_Node => |
| Unchecked_Convert_To (RTE (RE_Tag), |
| New_Reference_To |
| (Node (Sec_DT_Typ), Loc)))); |
| |
| if Num_Prims /= 0 then |
| Append_To (Elab_Code, |
| Build_Inherit_Prims (Loc, |
| Typ => Node (Iface), |
| Old_Tag_Node => |
| Unchecked_Convert_To |
| (RTE (RE_Tag), |
| New_Reference_To |
| (Node (Sec_DT_Ancestor), |
| Loc)), |
| New_Tag_Node => |
| Unchecked_Convert_To |
| (RTE (RE_Tag), |
| New_Reference_To |
| (Node (Sec_DT_Typ), Loc)), |
| Num_Prims => Num_Prims)); |
| end if; |
| end if; |
| |
| Next_Elmt (Sec_DT_Ancestor); |
| Next_Elmt (Sec_DT_Typ); |
| |
| if not Is_Interface (Etype (Typ)) then |
| |
| -- Inherit second secondary dispatch table |
| |
| Append_To (Elab_Code, |
| Build_Inherit_Predefined_Prims (Loc, |
| Old_Tag_Node => |
| Unchecked_Convert_To (RTE (RE_Tag), |
| New_Reference_To |
| (Node (Sec_DT_Ancestor), Loc)), |
| New_Tag_Node => |
| Unchecked_Convert_To (RTE (RE_Tag), |
| New_Reference_To |
| (Node (Sec_DT_Typ), Loc)))); |
| |
| if Num_Prims /= 0 then |
| Append_To (Elab_Code, |
| Build_Inherit_Prims (Loc, |
| Typ => Node (Iface), |
| Old_Tag_Node => |
| Unchecked_Convert_To |
| (RTE (RE_Tag), |
| New_Reference_To |
| (Node (Sec_DT_Ancestor), |
| Loc)), |
| New_Tag_Node => |
| Unchecked_Convert_To |
| (RTE (RE_Tag), |
| New_Reference_To |
| (Node (Sec_DT_Typ), Loc)), |
| Num_Prims => Num_Prims)); |
| end if; |
| end if; |
| end; |
| |
| 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)) |
| and then Ekind (Node (Sec_DT_Ancestor)) = E_Constant |
| 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; |
| end if; |
| |
| -- Generate code to register the Tag in the External_Tag hash table for |
| -- the pure Ada type only. |
| |
| -- Register_Tag (Dt_Ptr); |
| |
| -- Skip this action in the following cases: |
| -- 1) if Register_Tag is not available. |
| -- 2) in No_Run_Time mode. |
| -- 3) if Typ is an abstract interface type (the secondary tags will |
| -- be registered later in types implementing this interface type). |
| -- 4) if Typ is not defined at the library level (this is required |
| -- to avoid adding concurrency control to the hash table used |
| -- by the run-time to register the tags). |
| |
| -- Generate: |
| -- if No_Reg then |
| -- [ Elab_Code ] |
| -- [ Register_Tag (Dt_Ptr); ] |
| -- No_Reg := False; |
| -- end if; |
| |
| if not No_Run_Time_Mode |
| and then Is_Library_Level_Entity (Typ) |
| and then RTE_Available (RE_Register_Tag) |
| 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; |
| |
| 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)); |
| |
| -- Populate the two auxiliary tables used for dispatching |
| -- asynchronous, conditional and timed selects for synchronized |
| -- types that implement a limited interface. |
| |
| if Ada_Version >= Ada_05 |
| and then Is_Concurrent_Record_Type (Typ) |
| and then Has_Abstract_Interfaces (Typ) |
| then |
| Append_List_To (Result, |
| Make_Select_Specific_Data_Table (Typ)); |
| end if; |
| |
| Analyze_List (Result, Suppress => All_Checks); |
| Set_Has_Dispatch_Table (Typ); |
| |
| return Result; |
| end Make_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 : Nat := 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 Present (Full_View (Conc_Typ)) then |
| Conc_Typ := Full_View (Conc_Typ); |
| end if; |
| |
| 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 |
| Prim := Node (Prim_Elmt); |
| |
| if not (Is_Predefined_Dispatching_Operation (Prim) |
| or else Is_Predefined_Dispatching_Alias (Prim)) |
| 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); |
| |
| -- Look for primitive overriding an abstract interface subprogram |
| |
| if Present (Abstract_Interface_Alias (Prim)) |
| and then not Examined (UI_To_Int (DT_Position (Alias (Prim)))) |
| then |
| Prim_Pos := DT_Position (Alias (Prim)); |
| pragma Assert (UI_To_Int (Prim_Pos) <= Nb_Prim); |
| Examined (UI_To_Int (Prim_Pos)) := True; |
| |
| -- Set the primitive operation kind regardless of subprogram |
| -- type. Generate: |
| -- Ada.Tags.Set_Prim_Op_Kind (DT_Ptr, <position>, <kind>); |
| |
| Append_To (Assignments, |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Reference_To (RTE (RE_Set_Prim_Op_Kind), Loc), |
| Parameter_Associations => New_List ( |
| New_Reference_To (DT_Ptr, Loc), |
| Make_Integer_Literal (Loc, Prim_Pos), |
| Prim_Op_Kind (Alias (Prim), Typ)))); |
| |
| -- Retrieve the root of the alias chain |
| |
| Prim_Als := Prim; |
| while Present (Alias (Prim_Als)) loop |
| Prim_Als := Alias (Prim_Als); |
| end loop; |
| |
| -- In the case of an entry wrapper, set the entry index |
| |
| if Ekind (Prim) = E_Procedure |
| 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_Procedure_Call_Statement (Loc, |
| Name => |
| New_Reference_To (RTE (RE_Set_Entry_Index), Loc), |
| Parameter_Associations => 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; |
| |
| Next_Elmt (Prim_Elmt); |
| end loop; |
| end; |
| |
| return Assignments; |
| end Make_Select_Specific_Data_Table; |
| |
| --------------- |
| -- Make_Tags -- |
| --------------- |
| |
| function Make_Tags (Typ : Entity_Id) return List_Id is |
| Loc : constant Source_Ptr := Sloc (Typ); |
| Tname : constant Name_Id := Chars (Typ); |
| Result : constant List_Id := New_List; |
| AI_Tag_Comp : Elmt_Id; |
| DT : Node_Id; |
| DT_Constr_List : List_Id; |
| DT_Ptr : Node_Id; |
| Iface_DT_Ptr : Node_Id; |
| Nb_Prim : Nat; |
| Suffix_Index : Int; |
| Typ_Name : Name_Id; |
| Typ_Comps : Elist_Id; |
| |
| begin |
| -- 1) Generate the primary and secondary tag entities |
| |
| -- Collect the components associated with secondary dispatch tables |
| |
| if Has_Abstract_Interfaces (Typ) then |
| Collect_Interface_Components (Typ, Typ_Comps); |
| end if; |
| |
| -- 1) Generate the primary tag entity |
| |
| DT_Ptr := Make_Defining_Identifier (Loc, |
| New_External_Name (Tname, 'P')); |
| Set_Etype (DT_Ptr, RTE (RE_Tag)); |
| |
| -- Import the forward declaration of the Dispatch Table wrapper record |
| -- (Make_DT will take care of its exportation) |
| |
| if Building_Static_DT (Typ) then |
| DT := Make_Defining_Identifier (Loc, |
| New_External_Name (Tname, 'T')); |
| |
| -- Generate: |
| -- DT : static aliased constant Dispatch_Table_Wrapper (Nb_Prim); |
| -- $pragma import (ada, DT); |
| |
| Set_Is_Imported (DT); |
| |
| -- The scope must be set now to call Get_External_Name |
| |
| Set_Scope (DT, Current_Scope); |
| |
| Get_External_Name (DT, True); |
| Set_Interface_Name (DT, |
| Make_String_Literal (Loc, |
| Strval => String_From_Name_Buffer)); |
| |
| -- Ensure proper Sprint output of this implicit importation |
| |
| Set_Is_Internal (DT); |
| |
| -- Save this entity to allow Make_DT to generate its exportation |
| |
| Set_Dispatch_Table_Wrapper (Typ, DT); |
| |
| if Has_DT (Typ) then |
| -- Calculate the number of primitives of the dispatch table and |
| -- the size of the Type_Specific_Data record. |
| |
| Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ))); |
| |
| -- If the tagged type has no primitives we add a dummy slot |
| -- whose address will be the tag of this type. |
| |
| if Nb_Prim = 0 then |
| DT_Constr_List := |
| New_List (Make_Integer_Literal (Loc, 1)); |
| else |
| DT_Constr_List := |
| New_List (Make_Integer_Literal (Loc, Nb_Prim)); |
| end if; |
| |
| Append_To (Result, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => DT, |
| Aliased_Present => True, |
| Constant_Present => True, |
| Object_Definition => |
| Make_Subtype_Indication (Loc, |
| Subtype_Mark => |
| New_Reference_To (RTE (RE_Dispatch_Table_Wrapper), Loc), |
| Constraint => Make_Index_Or_Discriminant_Constraint (Loc, |
| Constraints => DT_Constr_List)))); |
| |
| Append_To (Result, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => DT_Ptr, |
| Constant_Present => True, |
| Object_Definition => New_Reference_To (RTE (RE_Tag), Loc), |
| Expression => |
| Unchecked_Convert_To (RTE (RE_Tag), |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| Make_Selected_Component (Loc, |
| Prefix => New_Reference_To (DT, Loc), |
| Selector_Name => |
| New_Occurrence_Of |
| (RTE_Record_Component (RE_Prims_Ptr), Loc)), |
| Attribute_Name => Name_Address)))); |
| |
| -- No dispatch table required |
| |
| else |
| Append_To (Result, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => DT, |
| Aliased_Present => True, |
| Constant_Present => True, |
| Object_Definition => |
| New_Reference_To (RTE (RE_No_Dispatch_Table_Wrapper), Loc))); |
| |
| Append_To (Result, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => DT_Ptr, |
| Constant_Present => True, |
| Object_Definition => New_Reference_To (RTE (RE_Tag), Loc), |
| Expression => |
| Unchecked_Convert_To (RTE (RE_Tag), |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| Make_Selected_Component (Loc, |
| Prefix => New_Reference_To (DT, Loc), |
| Selector_Name => |
| New_Occurrence_Of |
| (RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)), |
| Attribute_Name => Name_Address)))); |
| end if; |
| |
| Set_Is_True_Constant (DT_Ptr); |
| Set_Is_Statically_Allocated (DT_Ptr); |
| end if; |
| |
| pragma Assert (No (Access_Disp_Table (Typ))); |
| Set_Access_Disp_Table (Typ, New_Elmt_List); |
| Append_Elmt (DT_Ptr, Access_Disp_Table (Typ)); |
| |
| -- 2) Generate the secondary tag entities |
| |
| if Has_Abstract_Interfaces (Typ) then |
| Suffix_Index := 0; |
| |
| -- For each interface type we build an unique external name |
| -- associated with its corresponding secondary dispatch table. |
| -- This external name will be used to declare an object that |
| -- references this secondary dispatch table, value that will be |
| -- used for the elaboration of Typ's objects and also for the |
| -- elaboration of objects of derivations of Typ that do not |
| -- override the primitive operation of this interface type. |
| |
| AI_Tag_Comp := First_Elmt (Typ_Comps); |
| while Present (AI_Tag_Comp) loop |
| Get_Secondary_DT_External_Name |
| (Typ, Related_Type (Node (AI_Tag_Comp)), Suffix_Index); |
| |
| Typ_Name := Name_Find; |
| |
| Iface_DT_Ptr := |
| Make_Defining_Identifier (Loc, |
| Chars => New_External_Name (Typ_Name, 'P')); |
| Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag)); |
| Set_Ekind (Iface_DT_Ptr, E_Constant); |
| Set_Is_Tag (Iface_DT_Ptr); |
| Set_Has_Thunks (Iface_DT_Ptr); |
| Set_Is_Statically_Allocated (Iface_DT_Ptr); |
| Set_Is_True_Constant (Iface_DT_Ptr); |
| Set_Related_Type |
| (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp))); |
| Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ)); |
| |
| Iface_DT_Ptr := |
| Make_Defining_Identifier (Loc, |
| Chars => New_External_Name (Typ_Name, 'D')); |
| Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag)); |
| Set_Ekind (Iface_DT_Ptr, E_Constant); |
| Set_Is_Tag (Iface_DT_Ptr); |
| Set_Is_Statically_Allocated (Iface_DT_Ptr); |
| Set_Is_True_Constant (Iface_DT_Ptr); |
| Set_Related_Type |
| (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp))); |
| Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ)); |
| |
| Next_Elmt (AI_Tag_Comp); |
| end loop; |
| end if; |
| |
| -- 3) At the end of Access_Disp_Table we add the entity of an access |
| -- type declaration. It is used by Build_Get_Prim_Op_Address to |
| -- expand dispatching calls through the primary dispatch table. |
| |
| -- Generate: |
| -- type Typ_DT is array (1 .. Nb_Prims) of Address; |
| -- type Typ_DT_Acc is access Typ_DT; |
| |
| declare |
| Name_DT_Prims : constant Name_Id := |
| New_External_Name (Tname, 'G'); |
| Name_DT_Prims_Acc : constant Name_Id := |
| New_External_Name (Tname, 'H'); |
| DT_Prims : constant Entity_Id := |
| Make_Defining_Identifier (Loc, Name_DT_Prims); |
| DT_Prims_Acc : constant Entity_Id := |
| Make_Defining_Identifier (Loc, |
| Name_DT_Prims_Acc); |
| begin |
| Append_To (Result, |
| Make_Full_Type_Declaration (Loc, |
| Defining_Identifier => DT_Prims, |
| Type_Definition => |
| Make_Constrained_Array_Definition (Loc, |
| Discrete_Subtype_Definitions => New_List ( |
| Make_Range (Loc, |
| Low_Bound => Make_Integer_Literal (Loc, 1), |
| High_Bound => Make_Integer_Literal (Loc, |
| DT_Entry_Count |
| (First_Tag_Component (Typ))))), |
| Component_Definition => |
| Make_Component_Definition (Loc, |
| Subtype_Indication => |
| New_Reference_To (RTE (RE_Address), Loc))))); |
| |
| Append_To (Result, |
| Make_Full_Type_Declaration (Loc, |
| Defining_Identifier => DT_Prims_Acc, |
| Type_Definition => |
| Make_Access_To_Object_Definition (Loc, |
| Subtype_Indication => |
| New_Occurrence_Of (DT_Prims, Loc)))); |
| |
| Append_Elmt (DT_Prims_Acc, Access_Disp_Table (Typ)); |
| |
| -- Analyze the resulting list and suppress the generation of the |
| -- Init_Proc associated with the above array declaration because |
| -- we never use such type in object declarations; this type is only |
| -- used to simplify the expansion associated with dispatching calls. |
| |
| Analyze_List (Result); |
| Set_Suppress_Init_Proc (Base_Type (DT_Prims)); |
| end; |
| |
| Set_Ekind (DT_Ptr, E_Constant); |
| Set_Is_Tag (DT_Ptr); |
| Set_Related_Type (DT_Ptr, Typ); |
| |
| return Result; |
| end Make_Tags; |
| |
| ----------------------------------- |
| -- 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; |
| |
| ------------------------ |
| -- Register_Primitive -- |
| ------------------------ |
| |
| procedure Register_Primitive |
| (Loc : Source_Ptr; |
| Prim : Entity_Id; |
| Ins_Nod : Node_Id) |
| is |
| DT_Ptr : Entity_Id; |
| Iface_Prim : Entity_Id; |
| Iface_Typ : Entity_Id; |
| Iface_DT_Ptr : Entity_Id; |
| Iface_DT_Elmt : Elmt_Id; |
| L : List_Id; |
| Pos : Uint; |
| Tag : Entity_Id; |
| Thunk_Id : Entity_Id; |
| Thunk_Code : Node_Id; |
| Typ : Entity_Id; |
| |
| begin |
| pragma Assert (not Restriction_Active (No_Dispatching_Calls)); |
| |
| if not RTE_Available (RE_Tag) then |
| return; |
| end if; |
| |
| if not Present (Abstract_Interface_Alias (Prim)) then |
| Typ := Scope (DTC_Entity (Prim)); |
| DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); |
| Pos := DT_Position (Prim); |
| Tag := First_Tag_Component (Typ); |
| |
| if Is_Predefined_Dispatching_Operation (Prim) |
| or else Is_Predefined_Dispatching_Alias (Prim) |
| then |
| Insert_After (Ins_Nod, |
| Build_Set_Predefined_Prim_Op_Address (Loc, |
| Tag_Node => New_Reference_To (DT_Ptr, Loc), |
| Position => Pos, |
| Address_Node => Make_Attribute_Reference (Loc, |
| Prefix => New_Reference_To (Prim, Loc), |
| Attribute_Name => Name_Address))); |
| |
| else |
| pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag)); |
| |
| Insert_After (Ins_Nod, |
| Build_Set_Prim_Op_Address (Loc, |
| Typ => Typ, |
| Tag_Node => New_Reference_To (DT_Ptr, Loc), |
| Position => Pos, |
| Address_Node => Make_Attribute_Reference (Loc, |
| Prefix => New_Reference_To (Prim, Loc), |
| Attribute_Name => Name_Address))); |
| end if; |
| |
| -- Ada 2005 (AI-251): Primitive associated with an interface type |
| -- Generate the code of the thunk only if the interface type is not an |
| -- immediate ancestor of Typ; otherwise the dispatch table associated |
| -- with the interface is the primary dispatch table and we have nothing |
| -- else to do here. |
| |
| else |
| Typ := Find_Dispatching_Type (Alias (Prim)); |
| Iface_Typ := Find_Dispatching_Type (Abstract_Interface_Alias (Prim)); |
| |
| pragma Assert (Is_Interface (Iface_Typ)); |
| |
| Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code); |
| |
| if not Is_Parent (Iface_Typ, Typ) |
| and then Present (Thunk_Code) |
| then |
| -- Comment needed on why checks are suppressed. This is not just |
| -- efficiency, but fundamental functionality (see 1.295 RH, which |
| -- still does not answer this question) ??? |
| |
| Insert_Action (Ins_Nod, Thunk_Code, Suppress => All_Checks); |
| |
| -- Generate the code necessary to fill the appropriate entry of |
| -- the secondary dispatch table of Prim's controlling type with |
| -- Thunk_Id's address. |
| |
| Iface_DT_Elmt := Find_Interface_ADT (Typ, Iface_Typ); |
| Iface_DT_Ptr := Node (Iface_DT_Elmt); |
| pragma Assert (Has_Thunks (Iface_DT_Ptr)); |
| |
| Iface_Prim := Abstract_Interface_Alias (Prim); |
| Pos := DT_Position (Iface_Prim); |
| Tag := First_Tag_Component (Iface_Typ); |
| L := New_List; |
| |
| if Is_Predefined_Dispatching_Operation (Prim) |
| or else Is_Predefined_Dispatching_Alias (Prim) |
| then |
| Append_To (L, |
| Build_Set_Predefined_Prim_Op_Address (Loc, |
| Tag_Node => New_Reference_To (Iface_DT_Ptr, Loc), |
| Position => Pos, |
| Address_Node => |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Reference_To (Thunk_Id, Loc), |
| Attribute_Name => Name_Address))); |
| |
| Next_Elmt (Iface_DT_Elmt); |
| Iface_DT_Ptr := Node (Iface_DT_Elmt); |
| pragma Assert (not Has_Thunks (Iface_DT_Ptr)); |
| |
| Append_To (L, |
| Build_Set_Predefined_Prim_Op_Address (Loc, |
| Tag_Node => New_Reference_To (Iface_DT_Ptr, Loc), |
| Position => Pos, |
| Address_Node => |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Reference_To (Alias (Prim), Loc), |
| Attribute_Name => Name_Address))); |
| |
| Insert_Actions_After (Ins_Nod, L); |
| |
| else |
| pragma Assert (Pos /= Uint_0 |
| and then Pos <= DT_Entry_Count (Tag)); |
| |
| Append_To (L, |
| Build_Set_Prim_Op_Address (Loc, |
| Typ => Iface_Typ, |
| Tag_Node => New_Reference_To (Iface_DT_Ptr, Loc), |
| Position => Pos, |
| Address_Node => Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Reference_To (Thunk_Id, Loc), |
| Attribute_Name => Name_Address))); |
| |
| Next_Elmt (Iface_DT_Elmt); |
| Iface_DT_Ptr := Node (Iface_DT_Elmt); |
| pragma Assert (not Has_Thunks (Iface_DT_Ptr)); |
| |
| Append_To (L, |
| Build_Set_Prim_Op_Address (Loc, |
| Typ => Iface_Typ, |
| Tag_Node => New_Reference_To (Iface_DT_Ptr, Loc), |
| Position => Pos, |
| Address_Node => Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Reference_To (Alias (Prim), Loc), |
| Attribute_Name => Name_Address))); |
| |
| Insert_Actions_After (Ins_Nod, L); |
| end if; |
| end if; |
| end if; |
| end Register_Primitive; |
| |
| ------------------------- |
| -- Set_All_DT_Position -- |
| ------------------------- |
| |
| procedure Set_All_DT_Position (Typ : Entity_Id) is |
| |
| 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 |
| Op_Elmt : Elmt_Id; |
| Op : Entity_Id; |
| |
| begin |
| -- Aliased primitives are safe |
| |
| if Present (Alias (Prim)) then |
| return; |
| end if; |
| |
| Op_Elmt := First_Elmt (Primitive_Operations (Typ)); |
| while Present (Op_Elmt) loop |
| Op := Node (Op_Elmt); |
| |
| -- No need to check against itself |
| |
| if Op = Prim then |
| null; |
| |
| -- Primitive operations covering abstract interfaces are |
| -- allocated later |
| |
| elsif Present (Abstract_Interface_Alias (Op)) then |
| null; |
| |
| -- Predefined dispatching operations are completely safe. They |
| -- are allocated at fixed positions in a separate table. |
| |
| elsif Is_Predefined_Dispatching_Operation (Op) |
| or else Is_Predefined_Dispatching_Alias (Op) |
| then |
| null; |
| |
| -- Aliased subprograms are safe |
| |
| elsif Present (Alias (Op)) then |
| null; |
| |
| elsif DT_Position (Op) = DT_Position (Prim) |
| and then not Is_Predefined_Dispatching_Operation (Op) |
| and then not Is_Predefined_Dispatching_Operation (Prim) |
| and then not Is_Predefined_Dispatching_Alias (Op) |
| and then not Is_Predefined_Dispatching_Alias (Prim) |
| then |
| |
| -- Handle aliased subprograms |
| |
| declare |
| Op_1 : Entity_Id; |
| Op_2 : Entity_Id; |
| |
| begin |
| Op_1 := Op; |
| 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 (Op_Elmt); |
| end loop; |
| end Validate_Position; |
| |
| -- Local variables |
| |
| Parent_Typ : constant Entity_Id := Etype (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 : Nat; |
| DT_Length : Nat; |
| Nb_Prim : Nat; |
| Prim : Entity_Id; |
| Prim_Elmt : Elmt_Id; |
| |
| -- Start of processing for Set_All_DT_Position |
| |
| begin |
| -- Set the DT_Position for each primitive operation. Perform some |
| -- sanity checks to avoid to build completely inconsistant dispatch |
| -- tables. |
| |
| -- 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 |
| Prim := Node (Prim_Elmt); |
| |
| -- Predefined primitives have a separate dispatch table |
| |
| if not (Is_Predefined_Dispatching_Operation (Prim) |
| or else Is_Predefined_Dispatching_Alias (Prim)) |
| then |
| Count_Prim := Count_Prim + 1; |
| end if; |
| |
| Set_DTC_Entity_Value (Typ, Prim); |
| |
| -- 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 .. Count_Prim) of Boolean |
| := (others => False); |
| E : Entity_Id; |
| |
| procedure Handle_Inherited_Private_Subprograms (Typ : Entity_Id); |
| -- Called if Typ is declared in a nested package or a public child |
| -- package to handle inherited primitives that were inherited by Typ |
| -- in the visible part, but whose declaration was deferred because |
| -- the parent operation was private and not visible at that point. |
| |
| procedure Set_Fixed_Prim (Pos : Nat); |
| -- Sets to true an element of the Fixed_Prim table to indicate |
| -- that this entry of the dispatch table of Typ is occupied. |
| |
| ------------------------------------------ |
| -- Handle_Inherited_Private_Subprograms -- |
| ------------------------------------------ |
| |
| procedure Handle_Inherited_Private_Subprograms (Typ : Entity_Id) is |
| Op_List : Elist_Id; |
| Op_Elmt : Elmt_Id; |
| Op_Elmt_2 : Elmt_Id; |
| Prim_Op : Entity_Id; |
| Parent_Subp : Entity_Id; |
| |
| begin |
| Op_List := Primitive_Operations (Typ); |
| |
| Op_Elmt := First_Elmt (Op_List); |
| while Present (Op_Elmt) loop |
| Prim_Op := Node (Op_Elmt); |
| |
| -- Search primitives that are implicit operations with an |
| -- internal name whose parent operation has a normal name. |
| |
| if Present (Alias (Prim_Op)) |
| and then Find_Dispatching_Type (Alias (Prim_Op)) /= Typ |
| and then not Comes_From_Source (Prim_Op) |
| and then Is_Internal_Name (Chars (Prim_Op)) |
| and then not Is_Internal_Name (Chars (Alias (Prim_Op))) |
| then |
| Parent_Subp := Alias (Prim_Op); |
| |
| -- Check if the type has an explicit overriding for this |
| -- primitive. |
| |
| Op_Elmt_2 := Next_Elmt (Op_Elmt); |
| while Present (Op_Elmt_2) loop |
| if Chars (Node (Op_Elmt_2)) = Chars (Parent_Subp) |
| and then Type_Conformant (Prim_Op, Node (Op_Elmt_2)) |
| then |
| Set_DT_Position (Prim_Op, DT_Position (Parent_Subp)); |
| Set_DT_Position (Node (Op_Elmt_2), |
| DT_Position (Parent_Subp)); |
| Set_Fixed_Prim (UI_To_Int (DT_Position (Prim_Op))); |
| |
| goto Next_Primitive; |
| end if; |
| |
| Next_Elmt (Op_Elmt_2); |
| end loop; |
| end if; |
| |
| <<Next_Primitive>> |
| Next_Elmt (Op_Elmt); |
| end loop; |
| end Handle_Inherited_Private_Subprograms; |
| |
| -------------------- |
| -- Set_Fixed_Prim -- |
| -------------------- |
| |
| procedure Set_Fixed_Prim (Pos : Nat) is |
| begin |
| pragma Assert (Pos >= 0 and then Pos <= Count_Prim); |
| Fixed_Prim (Pos) := True; |
| exception |
| when Constraint_Error => |
| raise Program_Error; |
| end Set_Fixed_Prim; |
| |
| begin |
| -- In case of nested packages and public child package it may be |
| -- necessary a special management on inherited subprograms so that |
| -- the dispatch table is properly filled. |
| |
| if Ekind (Scope (Scope (Typ))) = E_Package |
| and then Scope (Scope (Typ)) /= Standard_Standard |
| and then ((Is_Derived_Type (Typ) and then not Is_Private_Type (Typ)) |
| or else |
| (Nkind (Parent (Typ)) = N_Private_Extension_Declaration |
| and then Is_Generic_Type (Typ))) |
| and then In_Open_Scopes (Scope (Etype (Typ))) |
| and then Typ = Base_Type (Typ) |
| then |
| Handle_Inherited_Private_Subprograms (Typ); |
| end if; |
| |
| -- 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)); |
| |
| elsif Is_Predefined_Dispatching_Alias (Prim) then |
| E := Alias (Prim); |
| while Present (Alias (E)) loop |
| E := Alias (E); |
| end loop; |
| |
| Set_DT_Position (Prim, Default_Prim_Op_Position (E)); |
| |
| -- Overriding primitives of ancestor abstract interfaces |
| |
| elsif Present (Abstract_Interface_Alias (Prim)) |
| and then Is_Parent |
| (Find_Dispatching_Type |
| (Abstract_Interface_Alias (Prim)), |
| Typ) |
| then |
| pragma Assert (DT_Position (Prim) = No_Uint |
| and then Present (DTC_Entity |
| (Abstract_Interface_Alias (Prim)))); |
| |
| E := Abstract_Interface_Alias (Prim); |
| Set_DT_Position (Prim, DT_Position (E)); |
| |
| pragma Assert |
| (DT_Position (Alias (Prim)) = No_Uint |
| or else DT_Position (Alias (Prim)) = DT_Position (E)); |
| Set_DT_Position (Alias (Prim), DT_Position (E)); |
| Set_Fixed_Prim (UI_To_Int (DT_Position (Prim))); |
| |
| -- Overriding primitives must use the same entry as the |
| -- overriden primitive. |
| |
| elsif not Present (Abstract_Interface_Alias (Prim)) |
| and then Present (Alias (Prim)) |
| and then Chars (Prim) = Chars (Alias (Prim)) |
| and then Find_Dispatching_Type (Alias (Prim)) /= Typ |
| and then Is_Parent |
| (Find_Dispatching_Type (Alias (Prim)), Typ) |
| and then Present (DTC_Entity (Alias (Prim))) |
| then |
| E := Alias (Prim); |
| Set_DT_Position (Prim, DT_Position (E)); |
| |
| if not Is_Predefined_Dispatching_Alias (E) then |
| Set_Fixed_Prim (UI_To_Int (DT_Position (E))); |
| end if; |
| 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 DT_Position (Prim) /= No_Uint 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; |
| pragma Assert (Nb_Prim <= Count_Prim); |
| exit when not Fixed_Prim (Nb_Prim); |
| end loop; |
| |
| Set_DT_Position (Prim, UI_From_Int (Nb_Prim)); |
| Set_Fixed_Prim (Nb_Prim); |
| 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 |
| pragma Assert (Present (Alias (Prim)) |
| and then Find_Dispatching_Type (Alias (Prim)) = Typ); |
| |
| -- Check if this entry will be placed in the primary DT |
| |
| if Is_Parent (Find_Dispatching_Type |
| (Abstract_Interface_Alias (Prim)), |
| Typ) |
| 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) |
| or else Is_Predefined_Dispatching_Alias (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) |
| or else Is_Predefined_Dispatching_Alias (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. |
| |
| -- Ada 2005 (AI-251): Hidden entities associated with abstract |
| -- interface primitives are not taken into account because the |
| -- check is done with the aliased primitive. |
| |
| if Is_Abstract_Type (Typ) |
| and then Is_Abstract_Subprogram (Prim) |
| and then Present (Alias (Prim)) |
| and then not Present (Abstract_Interface_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 (RM 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 cannot |
| -- fail) |
| |
| if DT_Entry_Count (The_Tag) < |
| DT_Entry_Count (First_Tag_Component (Parent_Typ)) |
| then |
| raise Program_Error; |
| 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_Type (Typ); |
| end if; |
| end Set_Default_Constructor; |
| |
| -------------------------- |
| -- Set_DTC_Entity_Value -- |
| -------------------------- |
| |
| procedure Set_DTC_Entity_Value |
| (Tagged_Type : Entity_Id; |
| Prim : Entity_Id) |
| is |
| begin |
| if Present (Abstract_Interface_Alias (Prim)) |
| and then Is_Interface |
| (Find_Dispatching_Type |
| (Abstract_Interface_Alias (Prim))) |
| then |
| Set_DTC_Entity (Prim, |
| Find_Interface_Tag |
| (T => Tagged_Type, |
| Iface => Find_Dispatching_Type |
| (Abstract_Interface_Alias (Prim)))); |
| else |
| Set_DTC_Entity (Prim, |
| First_Tag_Component (Tagged_Type)); |
| end if; |
| end Set_DTC_Entity_Value; |
| |
| ----------------- |
| -- 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_Type (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 Present (Full_View (Conc_Typ)) then |
| Conc_Typ := Full_View (Conc_Typ); |
| end if; |
| |
| 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 |
| |
| 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_Subprogram (Prim) then |
| Write_Str (" is abstract;"); |
| |
| -- Check if this is a null primitive |
| |
| elsif Comes_From_Source (Prim) |
| and then Ekind (Prim) = E_Procedure |
| and then Null_Present (Parent (Prim)) |
| then |
| Write_Str (" is null;"); |
| end if; |
| |
| Write_Eol; |
| |
| Next_Elmt (Elmt); |
| end loop; |
| end Write_DT; |
| |
| end Exp_Disp; |