Commit 75e4e36d by Arnaud Charlet

[multiple changes]

2016-07-06  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_attr.adb, sem_attr.adb, sem_ch13.adb: Minor reformatting.

2016-07-06  Arnaud Charlet  <charlet@adacore.com>

	* lib.adb (Check_Same_Extended_Unit): Prevent looping forever.
	* gnatbind.adb: Disable some consistency checks in codepeer mode,
	which are not needed.

2016-07-06  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch12.adb (Check_Fixed_Point_Actual): Add a warning when
	a formal fixed point type is instantiated with a type that has
	a user-defined arithmetic operations, but the generic has no
	corresponding formal functions. This is worth a warning because
	of the special semantics of fixed-point operators.

From-SVN: r238043
parent 1956beb8
2016-07-06 Hristian Kirtchev <kirtchev@adacore.com>
* exp_attr.adb, sem_attr.adb, sem_ch13.adb: Minor reformatting.
2016-07-06 Arnaud Charlet <charlet@adacore.com>
* lib.adb (Check_Same_Extended_Unit): Prevent looping forever.
* gnatbind.adb: Disable some consistency checks in codepeer mode,
which are not needed.
2016-07-06 Ed Schonberg <schonberg@adacore.com>
* sem_ch12.adb (Check_Fixed_Point_Actual): Add a warning when
a formal fixed point type is instantiated with a type that has
a user-defined arithmetic operations, but the generic has no
corresponding formal functions. This is worth a warning because
of the special semantics of fixed-point operators.
2016-07-06 Bob Duff <duff@adacore.com>
* sem_attr.adb (Analyze_Attribute): Allow any expression of
......
......@@ -3009,9 +3009,10 @@ package body Exp_Attr is
when Attribute_Enum_Rep => Enum_Rep : declare
Expr : Node_Id;
begin
-- Get the expression, which is X for Enum_Type'Enum_Rep (X)
-- or X'Enum_Rep.
-- Get the expression, which is X for Enum_Type'Enum_Rep (X) or
-- X'Enum_Rep.
if Is_Non_Empty_List (Exprs) then
Expr := First (Exprs);
......@@ -3019,8 +3020,8 @@ package body Exp_Attr is
Expr := Pref;
end if;
-- If the expression is an enumeration literal, it is
-- replaced by the literal value.
-- If the expression is an enumeration literal, it is replaced by the
-- literal value.
if Nkind (Expr) in N_Has_Entity
and then Ekind (Entity (Expr)) = E_Enumeration_Literal
......@@ -3029,8 +3030,8 @@ package body Exp_Attr is
Make_Integer_Literal (Loc, Enumeration_Rep (Entity (Expr))));
-- If this is a renaming of a literal, recover the representation
-- of the original. If it renames an expression there is nothing
-- to fold.
-- of the original. If it renames an expression there is nothing to
-- fold.
elsif Nkind (Expr) in N_Has_Entity
and then Ekind (Entity (Expr)) = E_Constant
......@@ -3056,8 +3057,7 @@ package body Exp_Attr is
-- might be an illegal conversion.
else
Rewrite (N,
OK_Convert_To (Typ, Relocate_Node (Expr)));
Rewrite (N, OK_Convert_To (Typ, Relocate_Node (Expr)));
end if;
Set_Etype (N, Typ);
......
......@@ -855,12 +855,15 @@ begin
end;
end if;
-- Perform consistency and correctness checks
-- Perform consistency and correctness checks. Disable these in CodePeer
-- mode where we want to be more flexible.
if not CodePeer_Mode then
Check_Duplicated_Subunits;
Check_Versions;
Check_Consistency;
Check_Configuration_Consistency;
end if;
-- List restrictions that could be applied to this partition
......
......@@ -38,6 +38,7 @@ with Csets; use Csets;
with Einfo; use Einfo;
with Fname; use Fname;
with Nlists; use Nlists;
with Opt; use Opt;
with Output; use Output;
with Sinfo; use Sinfo;
with Sinput; use Sinput;
......@@ -259,18 +260,22 @@ package body Lib is
------------------------------
function Check_Same_Extended_Unit (S1, S2 : Source_Ptr) return SEU_Result is
Sloc1 : Source_Ptr;
Sloc2 : Source_Ptr;
Sind1 : Source_File_Index;
Sind2 : Source_File_Index;
Max_Iterations : constant Nat := Maximum_Instantiations * 2;
-- Limit to prevent a potential infinite loop
Counter : Nat := 0;
Depth1 : Nat;
Depth2 : Nat;
Inst1 : Source_Ptr;
Inst2 : Source_Ptr;
Unum1 : Unit_Number_Type;
Unum2 : Unit_Number_Type;
Sind1 : Source_File_Index;
Sind2 : Source_File_Index;
Sloc1 : Source_Ptr;
Sloc2 : Source_Ptr;
Unit1 : Node_Id;
Unit2 : Node_Id;
Depth1 : Nat;
Depth2 : Nat;
Unum1 : Unit_Number_Type;
Unum2 : Unit_Number_Type;
begin
if S1 = No_Location or else S2 = No_Location then
......@@ -435,7 +440,13 @@ package body Lib is
return No;
<<Continue>>
null;
Counter := Counter + 1;
-- Prevent looping forever
if Counter > Max_Iterations then
raise Program_Error;
end if;
end loop;
end Check_Same_Extended_Unit;
......
......@@ -3742,6 +3742,7 @@ package body Sem_Attr is
Check_E1;
Check_Discrete_Type;
Resolve (E1, P_Base_Type);
elsif not Is_Discrete_Type (Etype (P)) then
Error_Attr_P ("prefix of % attribute must be of discrete type");
end if;
......
......@@ -1105,6 +1105,12 @@ package body Sem_Ch12 is
-- In Ada 2005, indicates partial parameterization of a formal
-- package. As usual an other association must be last in the list.
procedure Check_Fixed_Point_Actual (Actual : Node_Id);
-- Warn if an actual fixed-point type has user-defined arithmetic
-- operations, but there is no corresponding formal in the generic,
-- in which case the predefined operations will be used. This merits
-- a warning because of the special semantics of fixed point ops.
procedure Check_Overloaded_Formal_Subprogram (Formal : Entity_Id);
-- Apply RM 12.3(9): if a formal subprogram is overloaded, the instance
-- cannot have a named association for it. AI05-0025 extends this rule
......@@ -1187,6 +1193,52 @@ package body Sem_Ch12 is
end Check_Overloaded_Formal_Subprogram;
-------------------------------
-- Check_Fixed_Point_Actual --
-------------------------------
procedure Check_Fixed_Point_Actual (Actual : Node_Id) is
Typ : constant Entity_Id := Entity (Actual);
Prims : constant Elist_Id := Collect_Primitive_Operations (Typ);
Elem : Elmt_Id;
Formal : Node_Id;
begin
-- Locate primitive operations of the type that are arithmetic
-- operations.
Elem := First_Elmt (Prims);
while Present (Elem) loop
if Nkind (Node (Elem)) = N_Defining_Operator_Symbol then
-- Check whether the generic unit has a formal subprogram of
-- the same name. This does not check types but is good enough
-- to justify a warning.
Formal := First_Non_Pragma (Formals);
while Present (Formal) loop
if Nkind (Formal) = N_Formal_Concrete_Subprogram_Declaration
and then Chars (Defining_Entity (Formal)) =
Chars (Node (Elem))
then
exit;
end if;
Next (Formal);
end loop;
if No (Formal) then
Error_Msg_Sloc := Sloc (Node (Elem));
Error_Msg_NE
("?instance does not use primitive operation&#",
Actual, Node (Elem));
end if;
end if;
Next_Elmt (Elem);
end loop;
end Check_Fixed_Point_Actual;
-------------------------------
-- Has_Fully_Defined_Profile --
-------------------------------
......@@ -1613,6 +1665,10 @@ package body Sem_Ch12 is
(Formal, Match, Analyzed_Formal, Assoc),
Assoc);
if Is_Fixed_Point_Type (Entity (Match)) then
Check_Fixed_Point_Actual (Match);
end if;
-- An instantiation is a freeze point for the actuals,
-- unless this is a rewritten formal package, or the
-- formal is an Ada 2012 formal incomplete type.
......
......@@ -1937,7 +1937,7 @@ package body Sem_Ch13 is
if not Implementation_Defined_Aspect (A_Id) then
Error_Msg_Name_1 := Nam;
-- Not allowed for renaming declarations. Examine original
-- Not allowed for renaming declarations. Examine the original
-- node because a subprogram renaming may have been rewritten
-- as a body.
......
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