+ -------------------------
+ -- Init_Secondary_Tags --
+ -------------------------
+
+ procedure Init_Secondary_Tags
+ (Typ : Entity_Id;
+ Target : Node_Id;
+ Stmts_List : List_Id;
+ Fixed_Comps : Boolean := True;
+ Variable_Comps : Boolean := True)
+ is
+ Loc : constant Source_Ptr := Sloc (Target);
+
+ procedure Inherit_CPP_Tag
+ (Typ : Entity_Id;
+ Iface : Entity_Id;
+ Tag_Comp : Entity_Id;
+ Iface_Tag : Node_Id);
+ -- Inherit the C++ tag of the secondary dispatch table of Typ associated
+ -- with Iface. Tag_Comp is the component of Typ that stores Iface_Tag.
+
+ procedure Initialize_Tag
+ (Typ : Entity_Id;
+ Iface : Entity_Id;
+ Tag_Comp : Entity_Id;
+ Iface_Tag : Node_Id);
+ -- Initialize the tag of the secondary dispatch table of Typ associated
+ -- with Iface. Tag_Comp is the component of Typ that stores Iface_Tag.
+ -- Compiling under the CPP full ABI compatibility mode, if the ancestor
+ -- of Typ CPP tagged type we generate code to inherit the contents of
+ -- the dispatch table directly from the ancestor.
+
+ ---------------------
+ -- Inherit_CPP_Tag --
+ ---------------------
+
+ procedure Inherit_CPP_Tag
+ (Typ : Entity_Id;
+ Iface : Entity_Id;
+ Tag_Comp : Entity_Id;
+ Iface_Tag : Node_Id)
+ is
+ begin
+ pragma Assert (Is_CPP_Class (Etype (Typ)));
+
+ Append_To (Stmts_List,
+ Build_Inherit_Prims (Loc,
+ Typ => Iface,
+ Old_Tag_Node =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Copy_Tree (Target),
+ Selector_Name => New_Reference_To (Tag_Comp, Loc)),
+ New_Tag_Node =>
+ New_Reference_To (Iface_Tag, Loc),
+ Num_Prims =>
+ UI_To_Int (DT_Entry_Count (First_Tag_Component (Iface)))));
+ end Inherit_CPP_Tag;
+
+ --------------------
+ -- Initialize_Tag --
+ --------------------
+
+ procedure Initialize_Tag
+ (Typ : Entity_Id;
+ Iface : Entity_Id;
+ Tag_Comp : Entity_Id;
+ Iface_Tag : Node_Id)
+ is
+ Comp_Typ : Entity_Id;
+ Offset_To_Top_Comp : Entity_Id := Empty;
+
+ begin
+ -- Initialize the pointer to the secondary DT associated with the
+ -- interface.
+
+ if not Is_Ancestor (Iface, Typ) then
+ Append_To (Stmts_List,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Copy_Tree (Target),
+ Selector_Name => New_Reference_To (Tag_Comp, Loc)),
+ Expression =>
+ New_Reference_To (Iface_Tag, Loc)));
+ end if;
+
+ Comp_Typ := Scope (Tag_Comp);
+
+ -- Initialize the entries of the table of interfaces. We generate a
+ -- different call when the parent of the type has variable size
+ -- components.
+
+ if Comp_Typ /= Etype (Comp_Typ)
+ and then Is_Variable_Size_Record (Etype (Comp_Typ))
+ and then Chars (Tag_Comp) /= Name_uTag
+ then
+ pragma Assert (Present (DT_Offset_To_Top_Func (Tag_Comp)));
+
+ -- Issue error if Set_Dynamic_Offset_To_Top is not available in a
+ -- configurable run-time environment.
+
+ if not RTE_Available (RE_Set_Dynamic_Offset_To_Top) then
+ Error_Msg_CRT
+ ("variable size record with interface types", Typ);
+ return;
+ end if;
+
+ -- Generate:
+ -- Set_Dynamic_Offset_To_Top
+ -- (This => Init,
+ -- Interface_T => Iface'Tag,
+ -- Offset_Value => n,
+ -- Offset_Func => Fn'Address)
+
+ Append_To (Stmts_List,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Reference_To
+ (RTE (RE_Set_Dynamic_Offset_To_Top), Loc),
+ Parameter_Associations => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Copy_Tree (Target),
+ Attribute_Name => Name_Address),
+
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To
+ (Node (First_Elmt (Access_Disp_Table (Iface))),
+ Loc)),
+
+ Unchecked_Convert_To
+ (RTE (RE_Storage_Offset),
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Copy_Tree (Target),
+ Selector_Name =>
+ New_Reference_To (Tag_Comp, Loc)),
+ Attribute_Name => Name_Position)),
+
+ Unchecked_Convert_To (RTE (RE_Offset_To_Top_Function_Ptr),
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To
+ (DT_Offset_To_Top_Func (Tag_Comp), Loc),
+ Attribute_Name => Name_Address)))));
+
+ -- In this case the next component stores the value of the
+ -- offset to the top.
+
+ Offset_To_Top_Comp := Next_Entity (Tag_Comp);
+ pragma Assert (Present (Offset_To_Top_Comp));
+
+ Append_To (Stmts_List,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Copy_Tree (Target),
+ Selector_Name => New_Reference_To
+ (Offset_To_Top_Comp, Loc)),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Copy_Tree (Target),
+ Selector_Name =>
+ New_Reference_To (Tag_Comp, Loc)),
+ Attribute_Name => Name_Position)));
+
+ -- Normal case: No discriminants in the parent type
+
+ else
+ -- Don't need to set any value if this interface shares
+ -- the primary dispatch table.
+
+ if not Is_Ancestor (Iface, Typ) then
+ Append_To (Stmts_List,
+ Build_Set_Static_Offset_To_Top (Loc,
+ Iface_Tag => New_Reference_To (Iface_Tag, Loc),
+ Offset_Value =>
+ Unchecked_Convert_To (RTE (RE_Storage_Offset),
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Copy_Tree (Target),
+ Selector_Name =>
+ New_Reference_To (Tag_Comp, Loc)),
+ Attribute_Name => Name_Position))));
+ end if;
+
+ -- Generate:
+ -- Register_Interface_Offset
+ -- (This => Init,
+ -- Interface_T => Iface'Tag,
+ -- Is_Constant => True,
+ -- Offset_Value => n,
+ -- Offset_Func => null);
+
+ if RTE_Available (RE_Register_Interface_Offset) then
+ Append_To (Stmts_List,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Reference_To
+ (RTE (RE_Register_Interface_Offset), Loc),
+ Parameter_Associations => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Copy_Tree (Target),
+ Attribute_Name => Name_Address),
+
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To
+ (Node (First_Elmt (Access_Disp_Table (Iface))), Loc)),
+
+ New_Occurrence_Of (Standard_True, Loc),
+
+ Unchecked_Convert_To
+ (RTE (RE_Storage_Offset),
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Copy_Tree (Target),
+ Selector_Name =>
+ New_Reference_To (Tag_Comp, Loc)),
+ Attribute_Name => Name_Position)),
+
+ Make_Null (Loc))));
+ end if;
+ end if;
+ end Initialize_Tag;
+
+ -- Local variables
+
+ Full_Typ : Entity_Id;
+ Ifaces_List : Elist_Id;
+ Ifaces_Comp_List : Elist_Id;
+ Ifaces_Tag_List : Elist_Id;
+ Iface_Elmt : Elmt_Id;
+ Iface_Comp_Elmt : Elmt_Id;
+ Iface_Tag_Elmt : Elmt_Id;
+ Tag_Comp : Node_Id;
+ In_Variable_Pos : Boolean;
+
+ -- Start of processing for Init_Secondary_Tags
+
+ begin
+ -- Handle private types
+
+ if Present (Full_View (Typ)) then
+ Full_Typ := Full_View (Typ);
+ else
+ Full_Typ := Typ;
+ end if;
+
+ Collect_Interfaces_Info
+ (Full_Typ, Ifaces_List, Ifaces_Comp_List, Ifaces_Tag_List);
+
+ Iface_Elmt := First_Elmt (Ifaces_List);
+ Iface_Comp_Elmt := First_Elmt (Ifaces_Comp_List);
+ Iface_Tag_Elmt := First_Elmt (Ifaces_Tag_List);
+ while Present (Iface_Elmt) loop
+ Tag_Comp := Node (Iface_Comp_Elmt);
+
+ -- If we are compiling under the CPP full ABI compatibility mode and
+ -- the ancestor is a CPP_Pragma tagged type then we generate code to
+ -- inherit the contents of the dispatch table directly from the
+ -- ancestor.
+
+ if Is_CPP_Class (Etype (Full_Typ)) then
+ Inherit_CPP_Tag (Full_Typ,
+ Iface => Node (Iface_Elmt),
+ Tag_Comp => Tag_Comp,
+ Iface_Tag => Node (Iface_Tag_Elmt));
+
+ -- Otherwise generate code to initialize the tag
+
+ else
+ -- Check if the parent of the record type has variable size
+ -- components.
+
+ In_Variable_Pos := Scope (Tag_Comp) /= Etype (Scope (Tag_Comp))
+ and then Is_Variable_Size_Record (Etype (Scope (Tag_Comp)));
+
+ if (In_Variable_Pos and then Variable_Comps)
+ or else (not In_Variable_Pos and then Fixed_Comps)
+ then
+ Initialize_Tag (Full_Typ,
+ Iface => Node (Iface_Elmt),
+ Tag_Comp => Tag_Comp,
+ Iface_Tag => Node (Iface_Tag_Elmt));
+ end if;
+ end if;
+
+ Next_Elmt (Iface_Elmt);
+ Next_Elmt (Iface_Comp_Elmt);
+ Next_Elmt (Iface_Tag_Elmt);
+ end loop;
+ end Init_Secondary_Tags;
+
+ -----------------------------
+ -- Is_Variable_Size_Record --
+ -----------------------------
+
+ function Is_Variable_Size_Record (E : Entity_Id) return Boolean is
+ Comp : Entity_Id;
+ Comp_Typ : Entity_Id;
+ Idx : Node_Id;
+
+ function Is_Constant_Bound (Exp : Node_Id) return Boolean;
+ -- To simplify handling of array components. Determines whether the
+ -- given bound is constant (a constant or enumeration literal, or an
+ -- integer literal) as opposed to per-object, through an expression
+ -- or a discriminant.
+
+ -----------------------
+ -- Is_Constant_Bound --
+ -----------------------
+
+ function Is_Constant_Bound (Exp : Node_Id) return Boolean is
+ begin
+ if Nkind (Exp) = N_Integer_Literal then
+ return True;
+ else
+ return
+ Is_Entity_Name (Exp)
+ and then Present (Entity (Exp))
+ and then
+ (Ekind (Entity (Exp)) = E_Constant
+ or else Ekind (Entity (Exp)) = E_Enumeration_Literal);
+ end if;
+ end Is_Constant_Bound;
+
+ -- Start of processing for Is_Variable_Sized_Record
+
+ begin
+ pragma Assert (Is_Record_Type (E));
+
+ Comp := First_Entity (E);
+ while Present (Comp) loop
+ Comp_Typ := Etype (Comp);
+
+ if Is_Record_Type (Comp_Typ) then
+
+ -- Recursive call if the record type has discriminants
+
+ if Has_Discriminants (Comp_Typ)
+ and then Is_Variable_Size_Record (Comp_Typ)
+ then
+ return True;
+ end if;
+
+ elsif Is_Array_Type (Comp_Typ) then
+
+ -- Check if some index is initialized with a non-constant value
+
+ Idx := First_Index (Comp_Typ);
+ while Present (Idx) loop
+ if Nkind (Idx) = N_Range then
+ if not Is_Constant_Bound (Low_Bound (Idx))
+ or else
+ not Is_Constant_Bound (High_Bound (Idx))
+ then
+ return True;
+ end if;
+ end if;
+
+ Idx := Next_Index (Idx);
+ end loop;
+ end if;
+
+ Next_Entity (Comp);
+ end loop;
+
+ return False;
+ end Is_Variable_Size_Record;
+
+ ----------------------------------------
+ -- Make_Controlling_Function_Wrappers --
+ ----------------------------------------
+
+ procedure Make_Controlling_Function_Wrappers
+ (Tag_Typ : Entity_Id;
+ Decl_List : out List_Id;
+ Body_List : out List_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (Tag_Typ);
+ Prim_Elmt : Elmt_Id;
+ Subp : Entity_Id;
+ Actual_List : List_Id;
+ Formal_List : List_Id;
+ Formal : Entity_Id;
+ Par_Formal : Entity_Id;
+ Formal_Node : Node_Id;
+ Func_Body : Node_Id;
+ Func_Decl : Node_Id;
+ Func_Spec : Node_Id;
+ Return_Stmt : Node_Id;
+
+ begin
+ Decl_List := New_List;
+ Body_List := New_List;
+
+ Prim_Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
+
+ while Present (Prim_Elmt) loop
+ Subp := Node (Prim_Elmt);
+
+ -- If a primitive function with a controlling result of the type has
+ -- not been overridden by the user, then we must create a wrapper
+ -- function here that effectively overrides it and invokes the
+ -- (non-abstract) parent function. This can only occur for a null
+ -- extension. Note that functions with anonymous controlling access
+ -- results don't qualify and must be overridden. We also exclude
+ -- Input attributes, since each type will have its own version of
+ -- Input constructed by the expander. The test for Comes_From_Source
+ -- is needed to distinguish inherited operations from renamings
+ -- (which also have Alias set).
+
+ -- The function may be abstract, or require_Overriding may be set
+ -- for it, because tests for null extensions may already have reset
+ -- the Is_Abstract_Subprogram_Flag. If Requires_Overriding is not
+ -- set, functions that need wrappers are recognized by having an
+ -- alias that returns the parent type.
+
+ if Comes_From_Source (Subp)
+ or else No (Alias (Subp))
+ or else Ekind (Subp) /= E_Function
+ or else not Has_Controlling_Result (Subp)
+ or else Is_Access_Type (Etype (Subp))
+ or else Is_Abstract_Subprogram (Alias (Subp))
+ or else Is_TSS (Subp, TSS_Stream_Input)
+ then
+ goto Next_Prim;
+
+ elsif Is_Abstract_Subprogram (Subp)
+ or else Requires_Overriding (Subp)
+ or else
+ (Is_Null_Extension (Etype (Subp))
+ and then Etype (Alias (Subp)) /= Etype (Subp))
+ then
+ Formal_List := No_List;
+ Formal := First_Formal (Subp);
+
+ if Present (Formal) then
+ Formal_List := New_List;
+
+ while Present (Formal) loop
+ Append
+ (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)),
+ Null_Exclusion_Present =>
+ Null_Exclusion_Present (Parent (Formal)),
+ Parameter_Type =>
+ New_Reference_To (Etype (Formal), Loc),
+ Expression =>
+ New_Copy_Tree (Expression (Parent (Formal)))),
+ Formal_List);
+
+ Next_Formal (Formal);
+ end loop;
+ end if;
+
+ Func_Spec :=
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name =>
+ Make_Defining_Identifier (Loc,
+ Chars => Chars (Subp)),
+ Parameter_Specifications => Formal_List,
+ Result_Definition =>
+ New_Reference_To (Etype (Subp), Loc));
+
+ Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
+ Append_To (Decl_List, Func_Decl);
+
+ -- Build a wrapper body that calls the parent function. The body
+ -- contains a single return statement that returns an extension
+ -- aggregate whose ancestor part is a call to the parent function,
+ -- passing the formals as actuals (with any controlling arguments
+ -- converted to the types of the corresponding formals of the
+ -- parent function, which might be anonymous access types), and
+ -- having a null extension.
+
+ Formal := First_Formal (Subp);
+ Par_Formal := First_Formal (Alias (Subp));
+ Formal_Node := First (Formal_List);
+
+ if Present (Formal) then
+ Actual_List := New_List;
+ else
+ Actual_List := No_List;
+ end if;
+
+ while Present (Formal) loop
+ if Is_Controlling_Formal (Formal) then
+ Append_To (Actual_List,
+ Make_Type_Conversion (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of (Etype (Par_Formal), Loc),
+ Expression =>
+ New_Reference_To
+ (Defining_Identifier (Formal_Node), Loc)));
+ else
+ Append_To
+ (Actual_List,
+ New_Reference_To
+ (Defining_Identifier (Formal_Node), Loc));
+ end if;
+
+ Next_Formal (Formal);
+ Next_Formal (Par_Formal);
+ Next (Formal_Node);
+ end loop;
+
+ Return_Stmt :=
+ Make_Simple_Return_Statement (Loc,
+ Expression =>
+ Make_Extension_Aggregate (Loc,
+ Ancestor_Part =>
+ Make_Function_Call (Loc,
+ Name => New_Reference_To (Alias (Subp), Loc),
+ Parameter_Associations => Actual_List),
+ Null_Record_Present => True));
+
+ Func_Body :=
+ Make_Subprogram_Body (Loc,
+ Specification => New_Copy_Tree (Func_Spec),
+ Declarations => Empty_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Return_Stmt)));
+
+ Set_Defining_Unit_Name
+ (Specification (Func_Body),
+ Make_Defining_Identifier (Loc, Chars (Subp)));
+
+ Append_To (Body_List, Func_Body);
+
+ -- Replace the inherited function with the wrapper function
+ -- in the primitive operations list.
+
+ Override_Dispatching_Operation
+ (Tag_Typ, Subp, New_Op => Defining_Unit_Name (Func_Spec));
+ end if;
+
+ <<Next_Prim>>
+ Next_Elmt (Prim_Elmt);
+ end loop;
+ end Make_Controlling_Function_Wrappers;
+