OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes] 

2010-09-09  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch6.adb: Improve error message on untagged equality.
	* sem.adb (Semantics): Include subprogram bodies that act as spec.

2010-09-09  Javier Miranda  <miranda@adacore.com>

	* sem_ch13.adb, exp_ch13.adb: Undo previous change, unneeded.

From-SVN: r164062
This commit is contained in:
Arnaud Charlet 2010-09-09 12:01:41 +02:00
parent 7a963087d4
commit e5a58facaa
5 changed files with 180 additions and 147 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
gcc/ada/ChangeLog
View File

@ -1,3 +1,12 @@
2010-09-09 Ed Schonberg <schonberg@adacore.com>
* sem_ch6.adb: Improve error message on untagged equality.
* sem.adb (Semantics): Include subprogram bodies that act as spec.
2010-09-09 Javier Miranda <miranda@adacore.com>
* sem_ch13.adb, exp_ch13.adb: Undo previous change, unneeded.
2010-09-09 Robert Dewar <dewar@adacore.com>
* sem_ch13.adb, sem_ch6.adb, exp_ch3.adb: Minor reformatting.

113
gcc/ada/exp_ch3.adb
View File

@ -312,6 +312,12 @@ package body Exp_Ch3 is
-- invoking the inherited subprogram's parent subprogram and extended
-- with a null association list.
function Make_Null_Procedure_Specs (Tag_Typ : Entity_Id) return 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;
@ -5882,8 +5888,8 @@ package body Exp_Ch3 is
-- user-defined equality function). Used to pass this entity from
-- Make_Predefined_Primitive_Specs to Predefined_Primitive_Bodies.
Wrapper_Decl_List : List_Id := No_List;
Wrapper_Body_List : List_Id := No_List;
Wrapper_Decl_List : List_Id := No_List;
Wrapper_Body_List : List_Id := No_List;
-- Start of processing for Expand_Freeze_Record_Type
@ -6086,6 +6092,20 @@ 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)
and then Has_Interfaces (Def_Id)
then
Insert_Actions (N, Make_Null_Procedure_Specs (Def_Id));
end if;
Set_Is_Frozen (Def_Id);
Set_All_DT_Position (Def_Id);
@ -8004,6 +8024,95 @@ package body Exp_Ch3 is
end if;
end Make_Eq_If;
-------------------------------
-- 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;
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;
Append_To (Decl_List,
Make_Subprogram_Declaration (Loc,
Make_Procedure_Specification (Loc,
Defining_Unit_Name =>
Make_Defining_Identifier (Loc, Chars (Subp)),
Parameter_Specifications => Formal_List,
Null_Present => True)));
end if;
Next_Elmt (Prim_Elmt);
end loop;
return Decl_List;
end Make_Null_Procedure_Specs;
-------------------------------------
-- Make_Predefined_Primitive_Specs --
-------------------------------------

8
gcc/ada/sem.adb
View File

@ -1454,14 +1454,16 @@ package body Sem is
-- Do analysis, and then append the compilation unit onto the
-- Comp_Unit_List, if appropriate. This is done after analysis, so
-- if this unit depends on some others, they have already been
-- appended. We ignore bodies, except for the main unit itself. We
-- have also to guard against ill-formed subunits that have an
-- improper context.
-- appended. We ignore bodies, except for the main unit itself, and
-- for subprogram bodies that act as specs. We have also to guard
-- against ill-formed subunits that have an improper context.
Do_Analyze;
if Present (Comp_Unit)
and then Nkind (Unit (Comp_Unit)) in N_Proper_Body
and then (Nkind (Unit (Comp_Unit)) /= N_Subprogram_Body
or else not Acts_As_Spec (Comp_Unit))
and then not In_Extended_Main_Source_Unit (Comp_Unit)
then
null;

116
gcc/ada/sem_ch13.adb
View File

@ -44,7 +44,6 @@ 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;
@ -2357,106 +2356,6 @@ 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.
@ -2475,21 +2374,6 @@ 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

81
gcc/ada/sem_ch6.adb
View File

@ -166,6 +166,13 @@ package body Sem_Ch6 is
-- True otherwise. Proc is the entity for the procedure case and is used
-- in posting the warning message.
procedure Check_Untagged_Equality (Eq_Op : Entity_Id);
-- In Ada 2012, a primitive equality operator on an untagged record type
-- must appear before the type is frozen, and have the same visibility as
-- that of the type. This procedure checks that this rule is met, and
-- otherwise emits an error on the subprogram declaration and a warning
-- on the earlier freeze point if it is easy to locate.
procedure Enter_Overloaded_Entity (S : Entity_Id);
-- This procedure makes S, a new overloaded entity, into the first visible
-- entity with that name.
@ -5789,6 +5796,51 @@ package body Sem_Ch6 is
end if;
end Enter_Overloaded_Entity;
-----------------------------
-- Check_Untagged_Equality --
-----------------------------
procedure Check_Untagged_Equality (Eq_Op : Entity_Id) is
Typ : constant Entity_Id := Etype (First_Formal (Eq_Op));
Decl : constant Node_Id := Unit_Declaration_Node (Eq_Op);
Obj_Decl : Node_Id;
begin
if Nkind (Decl) = N_Subprogram_Declaration
and then Is_Record_Type (Typ)
and then not Is_Tagged_Type (Typ)
then
if Is_Frozen (Typ) then
Error_Msg_NE
("equality operator must be declared "
& "before type& is frozen", Eq_Op, Typ);
Obj_Decl := Next (Parent (Typ));
while Present (Obj_Decl)
and then Obj_Decl /= Decl
loop
if Nkind (Obj_Decl) = N_Object_Declaration
and then Etype (Defining_Identifier (Obj_Decl)) = Typ
then
Error_Msg_NE ("type& is frozen by declaration?",
Obj_Decl, Typ);
Error_Msg_N
("\an equality operator cannot be declared after this "
& "point ('R'M 4.5.2 (9.8)) (Ada2012))?", Obj_Decl);
exit;
end if;
Next (Obj_Decl);
end loop;
elsif not In_Same_List (Parent (Typ), Decl)
and then not Is_Limited_Type (Typ)
then
Error_Msg_N ("equality operator appears too late", Eq_Op);
end if;
end if;
end Check_Untagged_Equality;
-----------------------------
-- Find_Corresponding_Spec --
-----------------------------
@ -7975,32 +8027,9 @@ package body Sem_Ch6 is
then
Make_Inequality_Operator (S);
-- In Ada 2012, a primitive equality operator on a record type
-- must appear before the type is frozen, and have the same
-- visibility as the type.
declare
Typ : constant Entity_Id := Etype (First_Formal (S));
Decl : constant Node_Id := Unit_Declaration_Node (S);
begin
if Ada_Version >= Ada_12
and then Nkind (Decl) = N_Subprogram_Declaration
and then Is_Record_Type (Typ)
then
if Is_Frozen (Typ) then
Error_Msg_NE
("equality operator must be declared "
& "before type& is frozen", S, Typ);
elsif not In_Same_List (Parent (Typ), Decl)
and then not Is_Limited_Type (Typ)
then
Error_Msg_N
("equality operator appears too late", S);
end if;
end if;
end;
if Ada_Version >= Ada_12 then
Check_Untagged_Equality (S);
end if;
end if;
end New_Overloaded_Entity;