Skip to content

R
riscv-gcc-1
Commit 0052da20 by Javier Miranda Committed by Arnaud Charlet
Options

sem_ch3.adb (Derive_Subprogram): The code that checks if a dispatching primitive… 

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
parent 498d1b80
Showing with 274 additions and 165 deletions
gcc/ada/ChangeLog
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.
......
gcc/ada/exp_ch3.adb
......@@ -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 --
-------------------------------------
......
gcc/ada/sem_ch13.adb
......@@ -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
......
gcc/ada/sem_ch3.adb
......@@ -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
......
gcc/ada/sem_ch6.adb
......@@ -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
......
gcc/ada/sem_ch6.ads
......@@ -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,
......
gcc/ada/sem_disp.adb
......@@ -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 --
--------------------------
......
gcc/ada/sem_disp.ads
......@@ -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.
......
gcc/ada/sem_type.adb
......@@ -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;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment