===================================================================
@@ -1567,41 +1567,9 @@ package body Sem_Ch3 is
if Is_Null_Interface_Primitive (Iface_Prim) then
goto Continue;
- -- if the tagged type is defined at library level then we
- -- invoke Check_Abstract_Overriding to report the error
- -- and thus avoid generating the dispatch tables.
-
- elsif Is_Library_Level_Tagged_Type (Tagged_Type) then
- Check_Abstract_Overriding (Tagged_Type);
- pragma Assert (Serious_Errors_Detected > 0);
- return;
-
- -- For tagged types defined in nested scopes it is still
- -- possible to cover this interface primitive by means of
- -- late overriding (see Override_Dispatching_Operation).
-
- -- Search in the list of primitives of the type for the
- -- entity that will be overridden in such case to reference
- -- it in the internal entity that we build here. If the
- -- primitive is not overridden then the error will be
- -- reported later as part of the analysis of entities
- -- defined in the enclosing scope.
-
else
- declare
- El : Elmt_Id;
-
- begin
- El := First_Elmt (Primitive_Operations (Tagged_Type));
- while Present (El)
- and then Alias (Node (El)) /= Iface_Prim
- loop
- Next_Elmt (El);
- end loop;
-
- pragma Assert (Present (El));
- Prim := Node (El);
- end;
+ pragma Assert (False);
+ raise Program_Error;
end if;
end if;
===================================================================
@@ -7625,6 +7625,7 @@ package body Sem_Ch6 is
if Ada_Version >= Ada_05
and then Present (Derived_Type)
+ and then Present (Alias (S))
and then Is_Dispatching_Operation (Alias (S))
and then Present (Find_Dispatching_Type (Alias (S)))
and then Is_Interface (Find_Dispatching_Type (Alias (S)))
===================================================================
@@ -1651,7 +1651,8 @@ package body Sem_Disp is
(Tagged_Type : Entity_Id;
Iface_Prim : Entity_Id) return Entity_Id
is
- E : Entity_Id;
+ E : Entity_Id;
+ El : Elmt_Id;
begin
pragma Assert (Is_Interface (Find_Dispatching_Type (Iface_Prim))
@@ -1660,6 +1661,8 @@ package body Sem_Disp is
Is_Interface
(Find_Dispatching_Type (Ultimate_Alias (Iface_Prim)))));
+ -- Search in the homonym chain
+
E := Current_Entity (Iface_Prim);
while Present (E) loop
if Is_Subprogram (E)
@@ -1672,6 +1675,23 @@ package body Sem_Disp is
E := Homonym (E);
end loop;
+ -- Search in the list of primitives of the type
+
+ El := First_Elmt (Primitive_Operations (Tagged_Type));
+ while Present (El) loop
+ E := Node (El);
+
+ if No (Interface_Alias (E))
+ and then Alias (E) = Iface_Prim
+ then
+ return Node (El);
+ end if;
+
+ Next_Elmt (El);
+ end loop;
+
+ -- Not found
+
return Empty;
end Find_Primitive_Covering_Interface;
===================================================================
@@ -82,10 +82,12 @@ package Sem_Disp is
function Find_Primitive_Covering_Interface
(Tagged_Type : Entity_Id;
Iface_Prim : Entity_Id) return Entity_Id;
- -- Search in the homonym chain for the primitive of Tagged_Type that
- -- covers Iface_Prim. The homonym chain traversal is required to catch
- -- primitives associated with the partial view of private types when
- -- processing the corresponding full view.
+ -- Search in the homonym chain for the primitive of Tagged_Type that covers
+ -- Iface_Prim. The homonym chain traversal is required to catch primitives
+ -- associated with the partial view of private types when processing the
+ -- corresponding full view. If the entity is not found then search for it
+ -- in the list of primitives of Tagged_Type. This latter search is needed
+ -- when the interface primitive is covered by a private subprogram.
function Is_Dynamically_Tagged (N : Node_Id) return Boolean;
-- Used to determine whether a call is dispatching, i.e. if is an
A derived type does not inherit a private operation from a parent type, but can dispatch to it. That is, its dispatch table includes a full copy of the dispatch table of the parent, even if some of its entries can never be named. After this patch the following test compiles and executes silently. package R is type I1 is interface; procedure Oper (Obj : I1'Class); private procedure Proc (Obj : I1) is null; end R; package body R is procedure Oper (Obj : I1'Class) is begin Obj.Proc; -- Dispatching end Oper; end; with R; package P1 is type Root is tagged private; private type Root is tagged null record; end; with P1; with R; package Q1 is type Child is new P1.Root and R.I1 with null record; end Q1; with P1, Q1, R; procedure Main1 is X : Q1.Child; begin R.Oper (X); end Main1; Tested on x86_64-pc-linux-gnu, committed on trunk 2010-10-05 Javier Miranda <miranda@adacore.com> * sem_ch3.adb (Add_Internal_Interface_Entities): Code reorganization: move code that searches in the list of primitives of a tagged type for the entity that will be overridden by user-defined routines. * sem_disp.adb (Find_Primitive_Covering_Interface): Move here code previously located in routine Add_Internal_Interface_Entities. * sem_disp.ads (Find_Primitive_Covering_Interface): Update documentation * sem_ch6.adb (New_Overloaded_Entity): Add missing check on availability of attribute Alias.