+ ------------------------
+ -- Find_Interface_ADT --
+ ------------------------
+
+ function Find_Interface_ADT
+ (T : Entity_Id;
+ Iface : Entity_Id) return Entity_Id
+ is
+ ADT : Elmt_Id;
+ Found : Boolean := False;
+ Typ : Entity_Id := T;
+
+ procedure Find_Secondary_Table (Typ : Entity_Id);
+ -- Internal subprogram used to recursively climb to the ancestors
+
+ --------------------------
+ -- Find_Secondary_Table --
+ --------------------------
+
+ procedure Find_Secondary_Table (Typ : Entity_Id) is
+ AI_Elmt : Elmt_Id;
+ AI : Node_Id;
+
+ begin
+ pragma Assert (Typ /= Iface);
+
+ -- Climb to the ancestor (if any) handling synchronized interface
+ -- derivations and private types
+
+ if Is_Concurrent_Record_Type (Typ) then
+ declare
+ Iface_List : constant List_Id := Abstract_Interface_List (Typ);
+
+ begin
+ if Is_Non_Empty_List (Iface_List) then
+ Find_Secondary_Table (Etype (First (Iface_List)));
+ end if;
+ end;
+
+ elsif Present (Full_View (Etype (Typ))) then
+ if Full_View (Etype (Typ)) /= Typ then
+ Find_Secondary_Table (Full_View (Etype (Typ)));
+ end if;
+
+ elsif Etype (Typ) /= Typ then
+ Find_Secondary_Table (Etype (Typ));
+ end if;
+
+ -- Traverse the list of interfaces implemented by the type
+
+ if not Found
+ and then Present (Abstract_Interfaces (Typ))
+ and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ))
+ then
+ AI_Elmt := First_Elmt (Abstract_Interfaces (Typ));
+ while Present (AI_Elmt) loop
+ AI := Node (AI_Elmt);
+
+ if AI = Iface or else Is_Ancestor (Iface, AI) then
+ Found := True;
+ return;
+ end if;
+
+ Next_Elmt (ADT);
+ Next_Elmt (AI_Elmt);
+ end loop;
+ end if;
+ end Find_Secondary_Table;
+
+ -- Start of processing for Find_Interface_ADT
+
+ begin
+ pragma Assert (Is_Interface (Iface));
+
+ -- Handle private types
+
+ if Has_Private_Declaration (Typ)
+ and then Present (Full_View (Typ))
+ then
+ Typ := Full_View (Typ);
+ end if;
+
+ -- Handle access types
+
+ if Is_Access_Type (Typ) then
+ Typ := Directly_Designated_Type (Typ);
+ end if;
+
+ -- Handle task and protected types implementing interfaces
+
+ if Is_Concurrent_Type (Typ) then
+ Typ := Corresponding_Record_Type (Typ);
+ end if;
+
+ pragma Assert
+ (not Is_Class_Wide_Type (Typ)
+ and then Ekind (Typ) /= E_Incomplete_Type);
+
+ ADT := Next_Elmt (First_Elmt (Access_Disp_Table (Typ)));
+ pragma Assert (Present (Node (ADT)));
+ Find_Secondary_Table (Typ);
+ pragma Assert (Found);
+ return Node (ADT);
+ end Find_Interface_ADT;
+
+ ------------------------
+ -- Find_Interface_Tag --
+ ------------------------
+
+ function Find_Interface_Tag
+ (T : Entity_Id;
+ Iface : Entity_Id) return Entity_Id
+ is
+ AI_Tag : Entity_Id;
+ Found : Boolean := False;
+ Typ : Entity_Id := T;
+
+ Is_Primary_Tag : Boolean := False;
+
+ Is_Sync_Typ : Boolean := False;
+ -- In case of non concurrent-record-types each parent-type has the
+ -- tags associated with the interface types that are not implemented
+ -- by the ancestors; concurrent-record-types have their whole list of
+ -- interface tags (and this case requires some special management).
+
+ procedure Find_Tag (Typ : Entity_Id);
+ -- Internal subprogram used to recursively climb to the ancestors
+
+ --------------
+ -- Find_Tag --
+ --------------
+
+ procedure Find_Tag (Typ : Entity_Id) is
+ AI_Elmt : Elmt_Id;
+ AI : Node_Id;
+
+ begin
+ -- Check if the interface is an immediate ancestor of the type and
+ -- therefore shares the main tag.
+
+ if Typ = Iface then
+ if Is_Sync_Typ then
+ Is_Primary_Tag := True;
+ else
+ pragma Assert
+ (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
+ AI_Tag := First_Tag_Component (Typ);
+ end if;
+
+ Found := True;
+ return;
+ end if;
+
+ -- Handle synchronized interface derivations
+
+ if Is_Concurrent_Record_Type (Typ) then
+ declare
+ Iface_List : constant List_Id := Abstract_Interface_List (Typ);
+ begin
+ if Is_Non_Empty_List (Iface_List) then
+ Find_Tag (Etype (First (Iface_List)));
+ end if;
+ end;
+
+ -- Climb to the root type handling private types
+
+ elsif Present (Full_View (Etype (Typ))) then
+ if Full_View (Etype (Typ)) /= Typ then
+ Find_Tag (Full_View (Etype (Typ)));
+ end if;
+
+ elsif Etype (Typ) /= Typ then
+ Find_Tag (Etype (Typ));
+ end if;
+
+ -- Traverse the list of interfaces implemented by the type
+
+ if not Found
+ and then Present (Abstract_Interfaces (Typ))
+ and then not (Is_Empty_Elmt_List (Abstract_Interfaces (Typ)))
+ then
+ -- Skip the tag associated with the primary table
+
+ if not Is_Sync_Typ then
+ pragma Assert
+ (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
+ AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
+ pragma Assert (Present (AI_Tag));
+ end if;
+
+ AI_Elmt := First_Elmt (Abstract_Interfaces (Typ));
+ while Present (AI_Elmt) loop
+ AI := Node (AI_Elmt);
+
+ if AI = Iface or else Is_Ancestor (Iface, AI) then
+ Found := True;
+ return;
+ end if;
+
+ AI_Tag := Next_Tag_Component (AI_Tag);
+ Next_Elmt (AI_Elmt);
+ end loop;
+ end if;
+ end Find_Tag;
+
+ -- Start of processing for Find_Interface_Tag
+
+ begin
+ pragma Assert (Is_Interface (Iface));
+
+ -- Handle private types
+
+ if Has_Private_Declaration (Typ)
+ and then Present (Full_View (Typ))
+ then
+ Typ := Full_View (Typ);
+ end if;
+
+ -- Handle access types
+
+ if Is_Access_Type (Typ) then
+ Typ := Directly_Designated_Type (Typ);
+ end if;
+
+ -- Handle task and protected types implementing interfaces
+
+ if Is_Concurrent_Type (Typ) then
+ Typ := Corresponding_Record_Type (Typ);
+ end if;
+
+ if Is_Class_Wide_Type (Typ) then
+ Typ := Etype (Typ);
+ end if;
+
+ -- Handle entities from the limited view
+
+ if Ekind (Typ) = E_Incomplete_Type then
+ pragma Assert (Present (Non_Limited_View (Typ)));
+ Typ := Non_Limited_View (Typ);
+ end if;
+
+ if not Is_Concurrent_Record_Type (Typ) then
+ Find_Tag (Typ);
+ pragma Assert (Found);
+ return AI_Tag;
+
+ -- Concurrent record types
+
+ else
+ Is_Sync_Typ := True;
+ AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
+ Find_Tag (Typ);
+ pragma Assert (Found);
+
+ if Is_Primary_Tag then
+ return First_Tag_Component (Typ);
+ else
+ return AI_Tag;
+ end if;
+ end if;
+ end Find_Interface_Tag;
+
+ --------------------
+ -- Find_Interface --
+ --------------------
+
+ function Find_Interface
+ (T : Entity_Id;
+ Comp : Entity_Id) return Entity_Id
+ is
+ AI_Tag : Entity_Id;
+ Found : Boolean := False;
+ Iface : Entity_Id;
+ Typ : Entity_Id := T;
+
+ Is_Sync_Typ : Boolean := False;
+ -- In case of non concurrent-record-types each parent-type has the
+ -- tags associated with the interface types that are not implemented
+ -- by the ancestors; concurrent-record-types have their whole list of
+ -- interface tags (and this case requires some special management).
+
+ procedure Find_Iface (Typ : Entity_Id);
+ -- Internal subprogram used to recursively climb to the ancestors
+
+ ----------------
+ -- Find_Iface --
+ ----------------
+
+ procedure Find_Iface (Typ : Entity_Id) is
+ AI_Elmt : Elmt_Id;
+
+ begin
+ -- Climb to the root type
+
+ -- Handle sychronized interface derivations
+
+ if Is_Concurrent_Record_Type (Typ) then
+ declare
+ Iface_List : constant List_Id := Abstract_Interface_List (Typ);
+ begin
+ if Is_Non_Empty_List (Iface_List) then
+ Find_Iface (Etype (First (Iface_List)));
+ end if;
+ end;
+
+ -- Handle the common case
+
+ elsif Etype (Typ) /= Typ then
+ pragma Assert (not Present (Full_View (Etype (Typ))));
+ Find_Iface (Etype (Typ));
+ end if;
+
+ -- Traverse the list of interfaces implemented by the type
+
+ if not Found
+ and then Present (Abstract_Interfaces (Typ))
+ and then not (Is_Empty_Elmt_List (Abstract_Interfaces (Typ)))
+ then
+ -- Skip the tag associated with the primary table
+
+ if not Is_Sync_Typ then
+ pragma Assert
+ (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
+ AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
+ pragma Assert (Present (AI_Tag));
+ end if;
+
+ AI_Elmt := First_Elmt (Abstract_Interfaces (Typ));
+ while Present (AI_Elmt) loop
+ if AI_Tag = Comp then
+ Iface := Node (AI_Elmt);
+ Found := True;
+ return;
+ end if;
+
+ AI_Tag := Next_Tag_Component (AI_Tag);
+ Next_Elmt (AI_Elmt);
+ end loop;
+ end if;
+ end Find_Iface;
+
+ -- Start of processing for Find_Interface
+
+ begin
+ -- Handle private types
+
+ if Has_Private_Declaration (Typ)
+ and then Present (Full_View (Typ))
+ then
+ Typ := Full_View (Typ);
+ end if;
+
+ -- Handle access types
+
+ if Is_Access_Type (Typ) then
+ Typ := Directly_Designated_Type (Typ);
+ end if;
+
+ -- Handle task and protected types implementing interfaces
+
+ if Is_Concurrent_Type (Typ) then
+ Typ := Corresponding_Record_Type (Typ);
+ end if;
+
+ if Is_Class_Wide_Type (Typ) then
+ Typ := Etype (Typ);
+ end if;
+
+ -- Handle entities from the limited view
+
+ if Ekind (Typ) = E_Incomplete_Type then
+ pragma Assert (Present (Non_Limited_View (Typ)));
+ Typ := Non_Limited_View (Typ);
+ end if;
+
+ if Is_Concurrent_Record_Type (Typ) then
+ Is_Sync_Typ := True;
+ AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
+ end if;
+
+ Find_Iface (Typ);
+ pragma Assert (Found);
+ return Iface;
+ end Find_Interface;
+