+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.
-- 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;
-- 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
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);
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 --
-------------------------------------
-- 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;
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;
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.
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
-- 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.
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 --
-----------------------------
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;
OSDN Git Service
