sem_ch3.adb (Derive_Subprogram): The code that checks if a dispatching primitive covers some interface primitive...
2010-09-09 Javier Miranda <miranda@adacore.com> * sem_ch3.adb (Derive_Subprogram): The code that checks if a dispatching primitive covers some interface primitive is incomplete. Replace such code by the invocation of a new subprogram that provides this functionality. * sem_ch6.ads (Is_Interface_Conformant): Add missing documentation. * sem_ch6.adb (Check_Missing_Return): Minor reformating (Check_Convention): Complete if-statement conditition when reporting errors (to avoid assertion failure). * sem_ch13.adb (Make_Null_Procedure_Specs): This routine was previously located in exp_ch3. Relocated inside Analyze_Freeze_Entity. (Analyze_Freeze_Entity): Invoke routine that adds the spec of non overridden null interface primitives. * sem_type.adb (Is_Ancestor): If the parent of the partial view of a private type is an interface then use the parent of its full view to climb to its ancestor type. * sem_disp.ads, sem_disp.adb (Covers_Some_Interface): New subprogram. (Check_Dispatching_Operation): Extend assertion to handle wrappers of null interface primitives. (Is_Null_Interface_Primitive): New subprogram. * exp_ch3.adb (Make_Null_Procedure_Specs): Removed. (Expand_Freeze_Record_Type): Do not generate specs of null interface subprograms because they are now generated by Analyze_Freeze_Entity. From-SVN: r164059
This commit is contained in:
parent
498d1b808e
commit
0052da204e
|
@ -1,3 +1,28 @@
|
|||
2010-09-09 Javier Miranda <miranda@adacore.com>
|
||||
|
||||
* sem_ch3.adb (Derive_Subprogram): The code that checks if a
|
||||
dispatching primitive covers some interface primitive is incomplete.
|
||||
Replace such code by the invocation of a new subprogram that provides
|
||||
this functionality.
|
||||
* sem_ch6.ads (Is_Interface_Conformant): Add missing documentation.
|
||||
* sem_ch6.adb (Check_Missing_Return): Minor reformating
|
||||
(Check_Convention): Complete if-statement conditition when reporting
|
||||
errors (to avoid assertion failure).
|
||||
* sem_ch13.adb (Make_Null_Procedure_Specs): This routine was previously
|
||||
located in exp_ch3. Relocated inside Analyze_Freeze_Entity.
|
||||
(Analyze_Freeze_Entity): Invoke routine that adds the spec of non
|
||||
overridden null interface primitives.
|
||||
* sem_type.adb (Is_Ancestor): If the parent of the partial view of a
|
||||
private type is an interface then use the parent of its full view to
|
||||
climb to its ancestor type.
|
||||
* sem_disp.ads, sem_disp.adb (Covers_Some_Interface): New subprogram.
|
||||
(Check_Dispatching_Operation): Extend assertion to handle wrappers of
|
||||
null interface primitives.
|
||||
(Is_Null_Interface_Primitive): New subprogram.
|
||||
* exp_ch3.adb (Make_Null_Procedure_Specs): Removed.
|
||||
(Expand_Freeze_Record_Type): Do not generate specs of null interface
|
||||
subprograms because they are now generated by Analyze_Freeze_Entity.
|
||||
|
||||
2010-09-09 Robert Dewar <dewar@adacore.com>
|
||||
|
||||
* a-calfor.adb, sem_ch3.adb: Minor reformatting.
|
||||
|
|
|
@ -312,14 +312,6 @@ package body Exp_Ch3 is
|
|||
-- invoking the inherited subprogram's parent subprogram and extended
|
||||
-- with a null association list.
|
||||
|
||||
procedure Make_Null_Procedure_Specs
|
||||
(Tag_Typ : Entity_Id;
|
||||
Decl_List : out List_Id);
|
||||
-- Ada 2005 (AI-251): Makes specs for null procedures associated with any
|
||||
-- null procedures inherited from an interface type that have not been
|
||||
-- overridden. Only one null procedure will be created for a given set of
|
||||
-- inherited null procedures with homographic profiles.
|
||||
|
||||
function Predef_Spec_Or_Body
|
||||
(Loc : Source_Ptr;
|
||||
Tag_Typ : Entity_Id;
|
||||
|
@ -5886,7 +5878,6 @@ package body Exp_Ch3 is
|
|||
|
||||
Wrapper_Decl_List : List_Id := No_List;
|
||||
Wrapper_Body_List : List_Id := No_List;
|
||||
Null_Proc_Decl_List : List_Id := No_List;
|
||||
|
||||
-- Start of processing for Expand_Freeze_Record_Type
|
||||
|
||||
|
@ -6089,20 +6080,6 @@ package body Exp_Ch3 is
|
|||
Insert_List_Before_And_Analyze (N, Wrapper_Decl_List);
|
||||
end if;
|
||||
|
||||
-- Ada 2005 (AI-251): For a nonabstract type extension, build
|
||||
-- null procedure declarations for each set of homographic null
|
||||
-- procedures that are inherited from interface types but not
|
||||
-- overridden. This is done to ensure that the dispatch table
|
||||
-- entry associated with such null primitives are properly filled.
|
||||
|
||||
if Ada_Version >= Ada_05
|
||||
and then Etype (Def_Id) /= Def_Id
|
||||
and then not Is_Abstract_Type (Def_Id)
|
||||
then
|
||||
Make_Null_Procedure_Specs (Def_Id, Null_Proc_Decl_List);
|
||||
Insert_Actions (N, Null_Proc_Decl_List);
|
||||
end if;
|
||||
|
||||
Set_Is_Frozen (Def_Id);
|
||||
Set_All_DT_Position (Def_Id);
|
||||
|
||||
|
@ -8021,118 +7998,6 @@ package body Exp_Ch3 is
|
|||
end if;
|
||||
end Make_Eq_If;
|
||||
|
||||
-------------------------------
|
||||
-- Make_Null_Procedure_Specs --
|
||||
-------------------------------
|
||||
|
||||
procedure Make_Null_Procedure_Specs
|
||||
(Tag_Typ : Entity_Id;
|
||||
Decl_List : out List_Id)
|
||||
is
|
||||
Loc : constant Source_Ptr := Sloc (Tag_Typ);
|
||||
|
||||
Formal : Entity_Id;
|
||||
Formal_List : List_Id;
|
||||
New_Param_Spec : Node_Id;
|
||||
Parent_Subp : Entity_Id;
|
||||
Prim_Elmt : Elmt_Id;
|
||||
Proc_Decl : Node_Id;
|
||||
Subp : Entity_Id;
|
||||
|
||||
function Is_Null_Interface_Primitive (E : Entity_Id) return Boolean;
|
||||
-- Returns True if E is a null procedure that is an interface primitive
|
||||
|
||||
---------------------------------
|
||||
-- Is_Null_Interface_Primitive --
|
||||
---------------------------------
|
||||
|
||||
function Is_Null_Interface_Primitive (E : Entity_Id) return Boolean is
|
||||
begin
|
||||
return Comes_From_Source (E)
|
||||
and then Is_Dispatching_Operation (E)
|
||||
and then Ekind (E) = E_Procedure
|
||||
and then Null_Present (Parent (E))
|
||||
and then Is_Interface (Find_Dispatching_Type (E));
|
||||
end Is_Null_Interface_Primitive;
|
||||
|
||||
-- Start of processing for Make_Null_Procedure_Specs
|
||||
|
||||
begin
|
||||
Decl_List := New_List;
|
||||
Prim_Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
|
||||
while Present (Prim_Elmt) loop
|
||||
Subp := Node (Prim_Elmt);
|
||||
|
||||
-- If a null procedure inherited from an interface has not been
|
||||
-- overridden, then we build a null procedure declaration to
|
||||
-- override the inherited procedure.
|
||||
|
||||
Parent_Subp := Alias (Subp);
|
||||
|
||||
if Present (Parent_Subp)
|
||||
and then Is_Null_Interface_Primitive (Parent_Subp)
|
||||
then
|
||||
Formal_List := No_List;
|
||||
Formal := First_Formal (Subp);
|
||||
|
||||
if Present (Formal) then
|
||||
Formal_List := New_List;
|
||||
|
||||
while Present (Formal) loop
|
||||
|
||||
-- Copy the parameter spec including default expressions
|
||||
|
||||
New_Param_Spec :=
|
||||
New_Copy_Tree (Parent (Formal), New_Sloc => Loc);
|
||||
|
||||
-- Generate a new defining identifier for the new formal.
|
||||
-- required because New_Copy_Tree does not duplicate
|
||||
-- semantic fields (except itypes).
|
||||
|
||||
Set_Defining_Identifier (New_Param_Spec,
|
||||
Make_Defining_Identifier (Sloc (Formal),
|
||||
Chars => Chars (Formal)));
|
||||
|
||||
-- For controlling arguments we must change their
|
||||
-- parameter type to reference the tagged type (instead
|
||||
-- of the interface type)
|
||||
|
||||
if Is_Controlling_Formal (Formal) then
|
||||
if Nkind (Parameter_Type (Parent (Formal)))
|
||||
= N_Identifier
|
||||
then
|
||||
Set_Parameter_Type (New_Param_Spec,
|
||||
New_Occurrence_Of (Tag_Typ, Loc));
|
||||
|
||||
else pragma Assert
|
||||
(Nkind (Parameter_Type (Parent (Formal)))
|
||||
= N_Access_Definition);
|
||||
Set_Subtype_Mark (Parameter_Type (New_Param_Spec),
|
||||
New_Occurrence_Of (Tag_Typ, Loc));
|
||||
end if;
|
||||
end if;
|
||||
|
||||
Append (New_Param_Spec, Formal_List);
|
||||
|
||||
Next_Formal (Formal);
|
||||
end loop;
|
||||
end if;
|
||||
|
||||
Proc_Decl :=
|
||||
Make_Subprogram_Declaration (Loc,
|
||||
Make_Procedure_Specification (Loc,
|
||||
Defining_Unit_Name =>
|
||||
Make_Defining_Identifier (Loc, Chars (Subp)),
|
||||
Parameter_Specifications => Formal_List,
|
||||
Null_Present => True));
|
||||
Append_To (Decl_List, Proc_Decl);
|
||||
Analyze (Proc_Decl);
|
||||
end if;
|
||||
|
||||
Next_Elmt (Prim_Elmt);
|
||||
end loop;
|
||||
end Make_Null_Procedure_Specs;
|
||||
|
||||
-------------------------------------
|
||||
-- Make_Predefined_Primitive_Specs --
|
||||
-------------------------------------
|
||||
|
|
|
@ -44,6 +44,7 @@ with Sem; use Sem;
|
|||
with Sem_Aux; use Sem_Aux;
|
||||
with Sem_Ch3; use Sem_Ch3;
|
||||
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;
|
||||
|
@ -2356,6 +2357,106 @@ package body Sem_Ch13 is
|
|||
procedure Analyze_Freeze_Entity (N : Node_Id) is
|
||||
E : constant Entity_Id := Entity (N);
|
||||
|
||||
function Make_Null_Procedure_Specs (Tag_Typ : Entity_Id) return List_Id;
|
||||
-- Ada 2005 (AI-251): Makes specs for null procedures associated with
|
||||
-- null procedures inherited from interface types that have not been
|
||||
-- overridden. Only one null procedure will be created for a given
|
||||
-- set of inherited null procedures with homographic profiles.
|
||||
|
||||
-------------------------------
|
||||
-- Make_Null_Procedure_Specs --
|
||||
-------------------------------
|
||||
|
||||
function Make_Null_Procedure_Specs (Tag_Typ : Entity_Id) return List_Id
|
||||
is
|
||||
Decl_List : constant List_Id := New_List;
|
||||
Loc : constant Source_Ptr := Sloc (Tag_Typ);
|
||||
Formal : Entity_Id;
|
||||
Formal_List : List_Id;
|
||||
New_Param_Spec : Node_Id;
|
||||
Parent_Subp : Entity_Id;
|
||||
Prim_Elmt : Elmt_Id;
|
||||
Proc_Decl : Node_Id;
|
||||
Subp : Entity_Id;
|
||||
|
||||
begin
|
||||
Prim_Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
|
||||
while Present (Prim_Elmt) loop
|
||||
Subp := Node (Prim_Elmt);
|
||||
|
||||
-- If a null procedure inherited from an interface has not been
|
||||
-- overridden, then we build a null procedure declaration to
|
||||
-- override the inherited procedure.
|
||||
|
||||
Parent_Subp := Alias (Subp);
|
||||
|
||||
if Present (Parent_Subp)
|
||||
and then Is_Null_Interface_Primitive (Parent_Subp)
|
||||
then
|
||||
Formal_List := No_List;
|
||||
Formal := First_Formal (Subp);
|
||||
|
||||
if Present (Formal) then
|
||||
Formal_List := New_List;
|
||||
|
||||
while Present (Formal) loop
|
||||
|
||||
-- Copy the parameter spec including default expressions
|
||||
|
||||
New_Param_Spec :=
|
||||
New_Copy_Tree (Parent (Formal), New_Sloc => Loc);
|
||||
|
||||
-- Generate a new defining identifier for the new formal.
|
||||
-- required because New_Copy_Tree does not duplicate
|
||||
-- semantic fields (except itypes).
|
||||
|
||||
Set_Defining_Identifier (New_Param_Spec,
|
||||
Make_Defining_Identifier (Sloc (Formal),
|
||||
Chars => Chars (Formal)));
|
||||
|
||||
-- For controlling arguments we must change their
|
||||
-- parameter type to reference the tagged type (instead
|
||||
-- of the interface type)
|
||||
|
||||
if Is_Controlling_Formal (Formal) then
|
||||
if Nkind (Parameter_Type (Parent (Formal)))
|
||||
= N_Identifier
|
||||
then
|
||||
Set_Parameter_Type (New_Param_Spec,
|
||||
New_Occurrence_Of (Tag_Typ, Loc));
|
||||
|
||||
else pragma Assert
|
||||
(Nkind (Parameter_Type (Parent (Formal)))
|
||||
= N_Access_Definition);
|
||||
Set_Subtype_Mark (Parameter_Type (New_Param_Spec),
|
||||
New_Occurrence_Of (Tag_Typ, Loc));
|
||||
end if;
|
||||
end if;
|
||||
|
||||
Append (New_Param_Spec, Formal_List);
|
||||
|
||||
Next_Formal (Formal);
|
||||
end loop;
|
||||
end if;
|
||||
|
||||
Proc_Decl :=
|
||||
Make_Subprogram_Declaration (Loc,
|
||||
Make_Procedure_Specification (Loc,
|
||||
Defining_Unit_Name =>
|
||||
Make_Defining_Identifier (Loc, Chars (Subp)),
|
||||
Parameter_Specifications => Formal_List,
|
||||
Null_Present => True));
|
||||
Append_To (Decl_List, Proc_Decl);
|
||||
end if;
|
||||
|
||||
Next_Elmt (Prim_Elmt);
|
||||
end loop;
|
||||
|
||||
return Decl_List;
|
||||
end Make_Null_Procedure_Specs;
|
||||
|
||||
-- Start of processing for Analyze_Freeze_Entity
|
||||
|
||||
begin
|
||||
-- For tagged types covering interfaces add internal entities that link
|
||||
-- the primitives of the interfaces with the primitives that cover them.
|
||||
|
@ -2374,6 +2475,21 @@ package body Sem_Ch13 is
|
|||
and then not Is_Interface (E)
|
||||
and then Has_Interfaces (E)
|
||||
then
|
||||
-- Add specs of non-overridden null interface primitives. During
|
||||
-- semantic analysis this is required to ensure consistency of the
|
||||
-- contents of the list of primitives of the tagged type. Routine
|
||||
-- Add_Internal_Interface_Entities will take care of adding to such
|
||||
-- list the internal entities that link each interface primitive with
|
||||
-- the primitive of Tagged_Type that covers it; hence these specs
|
||||
-- must be added before invoking Add_Internal_Interface_Entities.
|
||||
-- In the expansion this consistency is required to ensure that the
|
||||
-- dispatch table slots associated with non-overridden null interface
|
||||
-- primitives are properly filled.
|
||||
|
||||
if not Is_Abstract_Type (E) then
|
||||
Insert_Actions (N, Make_Null_Procedure_Specs (E));
|
||||
end if;
|
||||
|
||||
-- This would be a good common place to call the routine that checks
|
||||
-- overriding of interface primitives (and thus factorize calls to
|
||||
-- Check_Abstract_Overriding located at different contexts in the
|
||||
|
|
|
@ -12284,10 +12284,6 @@ package body Sem_Ch3 is
|
|||
end if;
|
||||
end Set_Derived_Name;
|
||||
|
||||
-- Local variables
|
||||
|
||||
Parent_Overrides_Interface_Primitive : Boolean := False;
|
||||
|
||||
-- Start of processing for Derive_Subprogram
|
||||
|
||||
begin
|
||||
|
@ -12295,23 +12291,6 @@ package body Sem_Ch3 is
|
|||
New_Entity (Nkind (Parent_Subp), Sloc (Derived_Type));
|
||||
Set_Ekind (New_Subp, Ekind (Parent_Subp));
|
||||
|
||||
-- Check whether the parent overrides an interface primitive
|
||||
|
||||
if Is_Overriding_Operation (Parent_Subp) then
|
||||
declare
|
||||
E : Entity_Id := Parent_Subp;
|
||||
begin
|
||||
while Present (Overridden_Operation (E)) loop
|
||||
E := Ultimate_Alias (Overridden_Operation (E));
|
||||
end loop;
|
||||
|
||||
Parent_Overrides_Interface_Primitive :=
|
||||
Is_Dispatching_Operation (E)
|
||||
and then Present (Find_Dispatching_Type (E))
|
||||
and then Is_Interface (Find_Dispatching_Type (E));
|
||||
end;
|
||||
end if;
|
||||
|
||||
-- Check whether the inherited subprogram is a private operation that
|
||||
-- should be inherited but not yet made visible. Such subprograms can
|
||||
-- become visible at a later point (e.g., the private part of a public
|
||||
|
@ -12380,7 +12359,10 @@ package body Sem_Ch3 is
|
|||
-- overrides an interface primitive because interface primitives
|
||||
-- must be visible in the partial view of the parent (RM 7.3 (7.3/2))
|
||||
|
||||
elsif Parent_Overrides_Interface_Primitive then
|
||||
elsif Ada_Version >= Ada_05
|
||||
and then Is_Dispatching_Operation (Parent_Subp)
|
||||
and then Covers_Some_Interface (Parent_Subp)
|
||||
then
|
||||
Set_Derived_Name;
|
||||
|
||||
-- Otherwise, the type is inheriting a private operation, so enter
|
||||
|
|
|
@ -1714,7 +1714,7 @@ package body Sem_Ch6 is
|
|||
and then Present (Spec_Id)
|
||||
and then No_Return (Spec_Id)
|
||||
then
|
||||
Check_Returns (HSS, 'P', Missing_Ret, Spec_Id);
|
||||
Check_Returns (HSS, 'P', Missing_Ret, Spec_Id);
|
||||
end if;
|
||||
end Check_Missing_Return;
|
||||
|
||||
|
@ -4037,7 +4037,9 @@ package body Sem_Ch6 is
|
|||
Error_Msg_Name_2 := Get_Convention_Name (Convention (Op));
|
||||
Error_Msg_Sloc := Sloc (Op);
|
||||
|
||||
if Comes_From_Source (Op) then
|
||||
if Comes_From_Source (Op)
|
||||
or else No (Alias (Op))
|
||||
then
|
||||
if not Is_Overriding_Operation (Op) then
|
||||
Error_Msg_N ("\\primitive % defined #", Typ);
|
||||
else
|
||||
|
|
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1992-2010, 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- --
|
||||
|
@ -183,9 +183,9 @@ package Sem_Ch6 is
|
|||
(Tagged_Type : Entity_Id;
|
||||
Iface_Prim : Entity_Id;
|
||||
Prim : Entity_Id) return Boolean;
|
||||
-- Returns true if both primitives have a matching name and they are also
|
||||
-- type conformant. Special management is done for functions returning
|
||||
-- interfaces.
|
||||
-- Returns true if both primitives have a matching name, they are type
|
||||
-- conformant, and Prim is defined in the scope of Tagged_Type. Special
|
||||
-- management is done for functions returning interfaces.
|
||||
|
||||
function Mode_Conformant (New_Id, Old_Id : Entity_Id) return Boolean;
|
||||
-- Determine whether two callable entities (subprograms, entries,
|
||||
|
|
|
@ -91,6 +91,81 @@ package body Sem_Disp is
|
|||
Append_Unique_Elmt (New_Op, List);
|
||||
end Add_Dispatching_Operation;
|
||||
|
||||
---------------------------
|
||||
-- Covers_Some_Interface --
|
||||
---------------------------
|
||||
|
||||
function Covers_Some_Interface (Prim : Entity_Id) return Boolean is
|
||||
Tagged_Type : constant Entity_Id := Find_Dispatching_Type (Prim);
|
||||
Elmt : Elmt_Id;
|
||||
E : Entity_Id;
|
||||
|
||||
begin
|
||||
pragma Assert (Is_Dispatching_Operation (Prim));
|
||||
|
||||
-- Although this is a dispatching primitive we must check if its
|
||||
-- dispatching type is available because it may be the primitive
|
||||
-- of a private type not defined as tagged in its partial view.
|
||||
|
||||
if Present (Tagged_Type) and then Has_Interfaces (Tagged_Type) then
|
||||
|
||||
-- If the tagged type is frozen then the internal entities associated
|
||||
-- with interfaces are available in the list of primitives of the
|
||||
-- tagged type and can be used to speed up this search.
|
||||
|
||||
if Is_Frozen (Tagged_Type) then
|
||||
Elmt := First_Elmt (Primitive_Operations (Tagged_Type));
|
||||
while Present (Elmt) loop
|
||||
E := Node (Elmt);
|
||||
|
||||
if Present (Interface_Alias (E))
|
||||
and then Alias (E) = Prim
|
||||
then
|
||||
return True;
|
||||
end if;
|
||||
|
||||
Next_Elmt (Elmt);
|
||||
end loop;
|
||||
|
||||
-- Otherwise we must collect all the interface primitives and check
|
||||
-- if the Prim will override some interface primitive.
|
||||
|
||||
else
|
||||
declare
|
||||
Ifaces_List : Elist_Id;
|
||||
Iface_Elmt : Elmt_Id;
|
||||
Iface : Entity_Id;
|
||||
Iface_Prim : Entity_Id;
|
||||
|
||||
begin
|
||||
Collect_Interfaces (Tagged_Type, Ifaces_List);
|
||||
Iface_Elmt := First_Elmt (Ifaces_List);
|
||||
while Present (Iface_Elmt) loop
|
||||
Iface := Node (Iface_Elmt);
|
||||
|
||||
Elmt := First_Elmt (Primitive_Operations (Iface));
|
||||
while Present (Elmt) loop
|
||||
Iface_Prim := Node (Elmt);
|
||||
|
||||
if Chars (E) = Chars (Prim)
|
||||
and then Is_Interface_Conformant
|
||||
(Tagged_Type, Iface_Prim, Prim)
|
||||
then
|
||||
return True;
|
||||
end if;
|
||||
|
||||
Next_Elmt (Elmt);
|
||||
end loop;
|
||||
|
||||
Next_Elmt (Iface_Elmt);
|
||||
end loop;
|
||||
end;
|
||||
end if;
|
||||
end if;
|
||||
|
||||
return False;
|
||||
end Covers_Some_Interface;
|
||||
|
||||
-------------------------------
|
||||
-- Check_Controlling_Formals --
|
||||
-------------------------------
|
||||
|
@ -794,7 +869,10 @@ package body Sem_Disp is
|
|||
-- type by Make_Controlling_Function_Wrappers. However, attribute
|
||||
-- Is_Dispatching_Operation must be set to true.
|
||||
|
||||
-- 2. Subprograms associated with stream attributes (built by
|
||||
-- 2. Ada 2005 (AI-251): Wrapper procedures of null interface
|
||||
-- primitives.
|
||||
|
||||
-- 3. Subprograms associated with stream attributes (built by
|
||||
-- New_Stream_Subprogram)
|
||||
|
||||
if Present (Old_Subp)
|
||||
|
@ -805,9 +883,17 @@ package body Sem_Disp is
|
|||
((Ekind (Subp) = E_Function
|
||||
and then Is_Dispatching_Operation (Old_Subp)
|
||||
and then Is_Null_Extension (Base_Type (Etype (Subp))))
|
||||
or else
|
||||
(Ekind (Subp) = E_Procedure
|
||||
and then Is_Dispatching_Operation (Old_Subp)
|
||||
and then Present (Alias (Old_Subp))
|
||||
and then Is_Null_Interface_Primitive
|
||||
(Ultimate_Alias (Old_Subp)))
|
||||
or else Get_TSS_Name (Subp) = TSS_Stream_Read
|
||||
or else Get_TSS_Name (Subp) = TSS_Stream_Write);
|
||||
|
||||
Check_Controlling_Formals (Tagged_Type, Subp);
|
||||
Override_Dispatching_Operation (Tagged_Type, Old_Subp, Subp);
|
||||
Set_Is_Dispatching_Operation (Subp);
|
||||
end if;
|
||||
|
||||
|
@ -1602,6 +1688,19 @@ package body Sem_Disp is
|
|||
end if;
|
||||
end Is_Dynamically_Tagged;
|
||||
|
||||
---------------------------------
|
||||
-- Is_Null_Interface_Primitive --
|
||||
---------------------------------
|
||||
|
||||
function Is_Null_Interface_Primitive (E : Entity_Id) return Boolean is
|
||||
begin
|
||||
return Comes_From_Source (E)
|
||||
and then Is_Dispatching_Operation (E)
|
||||
and then Ekind (E) = E_Procedure
|
||||
and then Null_Present (Parent (E))
|
||||
and then Is_Interface (Find_Dispatching_Type (E));
|
||||
end Is_Null_Interface_Primitive;
|
||||
|
||||
--------------------------
|
||||
-- Is_Tag_Indeterminate --
|
||||
--------------------------
|
||||
|
|
|
@ -66,6 +66,11 @@ package Sem_Disp is
|
|||
-- of "OldSubp" is adjusted to point to the inherited procedure of the
|
||||
-- full view because it is always this one which has to be called.
|
||||
|
||||
function Covers_Some_Interface (Prim : Entity_Id) return Boolean;
|
||||
-- Returns true if Prim covers some interface primitive of its associated
|
||||
-- tagged type. The tagged type of Prim must be frozen when this function
|
||||
-- is invoked.
|
||||
|
||||
function Find_Controlling_Arg (N : Node_Id) return Node_Id;
|
||||
-- Returns the actual controlling argument if N is dynamically tagged,
|
||||
-- and Empty if it is not dynamically tagged.
|
||||
|
@ -87,6 +92,9 @@ package Sem_Disp is
|
|||
-- an expression of a class_Wide type, or a call to a function with
|
||||
-- controlling result where at least one operand is dynamically tagged.
|
||||
|
||||
function Is_Null_Interface_Primitive (E : Entity_Id) return Boolean;
|
||||
-- Returns True if E is a null procedure that is an interface primitive
|
||||
|
||||
function Is_Tag_Indeterminate (N : Node_Id) return Boolean;
|
||||
-- An expression is tag-indeterminate if it is a call that dispatches
|
||||
-- on result, and all controlling operands are also indeterminate.
|
||||
|
|
|
@ -2619,7 +2619,19 @@ package body Sem_Type is
|
|||
return True;
|
||||
|
||||
elsif Etype (Par) /= Par then
|
||||
Par := Etype (Par);
|
||||
|
||||
-- If this is a private type and its parent is an interface
|
||||
-- then use the parent of the full view (which is a type that
|
||||
-- implements such interface)
|
||||
|
||||
if Is_Private_Type (Par)
|
||||
and then Is_Interface (Etype (Par))
|
||||
and then Present (Full_View (Par))
|
||||
then
|
||||
Par := Etype (Full_View (Par));
|
||||
else
|
||||
Par := Etype (Par);
|
||||
end if;
|
||||
else
|
||||
return False;
|
||||
end if;
|
||||
|
|
Loading…
Reference in New Issue