[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:
parent
7a963087d4
commit
e5a58facaa
|
@ -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.
|
||||
|
|
|
@ -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 --
|
||||
-------------------------------------
|
||||
|
|
|
@ -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;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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;
|
||||
|
||||
|
|
Loading…
Reference in New Issue