- E := First_Entity (Typ);
- while Present (E) loop
- if Is_Tag (E)
- and then Chars (E) /= Name_uTag
- then
- Aux_N := Node (ADT);
- pragma Assert (Present (Aux_N));
-
- Iface := Find_Interface (Typ, E);
-
- -- 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 (Typ))
- and then not Debug_Flag_QQ
- then
- Args := New_List (
- Node1 =>
- Unchecked_Convert_To (RTE (RE_Tag),
- Make_Selected_Component (Loc,
- Prefix => New_Copy_Tree (Target),
- Selector_Name => New_Reference_To (E, Loc))),
- Node2 =>
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Reference_To (Aux_N, Loc)),
-
- Node3 =>
- Make_Integer_Literal (Loc,
- DT_Entry_Count (First_Tag_Component (Iface))));
-
- -- Issue error if Inherit_CPP_DT is not available
- -- in a configurable run-time environment.
-
- if not RTE_Available (RE_Inherit_CPP_DT) then
- Error_Msg_CRT ("cpp interfacing", Typ);
- return;
- end if;
-
- New_N :=
- Make_Procedure_Call_Statement (Loc,
- Name => New_Reference_To (RTE (RE_Inherit_CPP_DT),
- Loc),
- Parameter_Associations => Args);
-
- Append_To (Stmts_List, New_N);
- end if;
-
- -- Initialize the pointer to the secondary DT associated
- -- with the interface
-
- Append_To (Stmts_List,
- Make_Assignment_Statement (Loc,
- Name =>
- Make_Selected_Component (Loc,
- Prefix => New_Copy_Tree (Target),
- Selector_Name => New_Reference_To (E, Loc)),
- Expression =>
- New_Reference_To (Aux_N, Loc)));
-
- -- If the ancestor is CPP_Class, nothing else to do here
-
- if Is_CPP_Class (Etype (Typ)) and then not Debug_Flag_QQ then
- null;
-
- -- Otherwise, comment required ???
-
- else
- -- Issue error if Set_Offset_To_Top is not available in a
- -- configurable run-time environment.
-
- if not RTE_Available (RE_Set_Offset_To_Top) then
- Error_Msg_CRT ("abstract interface types", Typ);
- return;
- end if;
-
- -- We generate a different call when the parent of the
- -- type has discriminants.
-
- if Typ /= Etype (Typ)
- and then Has_Discriminants (Etype (Typ))
- then
- pragma Assert
- (Present (DT_Offset_To_Top_Func (E)));
-
- -- Generate:
- -- Set_Offset_To_Top
- -- (This => Init,
- -- Interface_T => Iface'Tag,
- -- Is_Constant => False,
- -- Offset_Value => n,
- -- Offset_Func => Fn'Address)
-
- Append_To (Stmts_List,
- Make_Procedure_Call_Statement (Loc,
- Name => New_Reference_To
- (RTE (RE_Set_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)),
-
- New_Occurrence_Of (Standard_False, 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 (E, Loc)),
- Attribute_Name => Name_Position)),
-
- Unchecked_Convert_To (RTE (RE_Address),
- Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To
- (DT_Offset_To_Top_Func (E),
- Loc),
- Attribute_Name =>
- Name_Address)))));
-
- -- In this case the next component stores the
- -- value of the offset to the top.
-
- Prev_E := E;
- Next_Entity (E);
- pragma Assert (Present (E));
-
- Append_To (Stmts_List,
- Make_Assignment_Statement (Loc,
- Name =>
- Make_Selected_Component (Loc,
- Prefix => New_Copy_Tree (Target),
- Selector_Name => New_Reference_To (E, Loc)),
- Expression =>
- Make_Attribute_Reference (Loc,
- Prefix =>
- Make_Selected_Component (Loc,
- Prefix => New_Copy_Tree (Target),
- Selector_Name =>
- New_Reference_To (Prev_E, Loc)),
- Attribute_Name => Name_Position)));
-
- -- Normal case: No discriminants in the parent type
-
- else
- -- Generate:
- -- Set_Offset_To_Top
- -- (This => Init,
- -- Interface_T => Iface'Tag,
- -- Is_Constant => True,
- -- Offset_Value => n,
- -- Offset_Func => null);
-
- Append_To (Stmts_List,
- Make_Procedure_Call_Statement (Loc,
- Name => New_Reference_To
- (RTE (RE_Set_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)),
-
- New_Occurrence_Of (Standard_True, Loc),