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

[multiple changes] 

2016-04-19  Hristian Kirtchev  <kirtchev@adacore.com>

	* checks.adb, sem_util.adb, sem_res.adb, sem_attr.adb: Minor
	reformatting.

2016-04-19  Ed Schonberg  <schonberg@adacore.com>

	* freeze.adb (Freeze_Profile): Refine predicate that checks
	whether a function that returns a limited view is declared in
	another unit and cannot be frozen at this point.

2016-04-19  Ed Schonberg  <schonberg@adacore.com>

	* exp_aggr.adb (Component_Count): Handle properly superflat
	arrays, i.e. empty arrays where Hi < Lo - 1, to ensure that the
	return value of the function is Natural, rather than leaving
	the handling of such arrays to the caller of this function.

From-SVN: r235200
This commit is contained in:
Arnaud Charlet 2016-04-19 15:10:35 +02:00
parent b314303784
commit b4213ffdaf
7 changed files with 64 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
gcc/ada/ChangeLog
View File

@ -1,3 +1,21 @@
2016-04-19 Hristian Kirtchev <kirtchev@adacore.com>
* checks.adb, sem_util.adb, sem_res.adb, sem_attr.adb: Minor
reformatting.
2016-04-19 Ed Schonberg <schonberg@adacore.com>
* freeze.adb (Freeze_Profile): Refine predicate that checks
whether a function that returns a limited view is declared in
another unit and cannot be frozen at this point.
2016-04-19 Ed Schonberg <schonberg@adacore.com>
* exp_aggr.adb (Component_Count): Handle properly superflat
arrays, i.e. empty arrays where Hi < Lo - 1, to ensure that the
return value of the function is Natural, rather than leaving
the handling of such arrays to the caller of this function.
2016-04-19 Arnaud Charlet <charlet@adacore.com>
* sem_prag.adb, sem_attr.adb, par-prag.adb, exp_aggr.adb, sem_type.adb

34
gcc/ada/checks.adb
View File

@ -2354,11 +2354,13 @@ package body Checks is
-- Local variables
Actual_1 : Node_Id;
Actual_2 : Node_Id;
Check : Node_Id;
Formal_1 : Entity_Id;
Formal_2 : Entity_Id;
Actual_1 : Node_Id;
Actual_2 : Node_Id;
Check : Node_Id;
Formal_1 : Entity_Id;
Formal_2 : Entity_Id;
Orig_Act_1 : Node_Id;
Orig_Act_2 : Node_Id;
-- Start of processing for Apply_Parameter_Aliasing_Checks
@ -2368,6 +2370,7 @@ package body Checks is
Actual_1 := First_Actual (Call);
Formal_1 := First_Formal (Subp);
while Present (Actual_1) and then Present (Formal_1) loop
Orig_Act_1 := Original_Actual (Actual_1);
-- Ensure that the actual is an object that is not passed by value.
-- Elementary types are always passed by value, therefore actuals of
@ -2378,30 +2381,27 @@ package body Checks is
-- will be done in place and a subsequent read will always see the
-- correct value, see RM 6.2 (12/3).
if Nkind (Original_Actual (Actual_1)) = N_Aggregate
or else
(Nkind (Original_Actual (Actual_1)) = N_Qualified_Expression
and then Nkind (Expression (Original_Actual (Actual_1))) =
N_Aggregate)
if Nkind (Orig_Act_1) = N_Aggregate
or else (Nkind (Orig_Act_1) = N_Qualified_Expression
and then Nkind (Expression (Orig_Act_1)) = N_Aggregate)
then
null;
elsif Is_Object_Reference (Original_Actual (Actual_1))
and then not Is_Elementary_Type (Etype (Original_Actual (Actual_1)))
and then
not Is_By_Reference_Type (Etype (Original_Actual (Actual_1)))
elsif Is_Object_Reference (Orig_Act_1)
and then not Is_Elementary_Type (Etype (Orig_Act_1))
and then not Is_By_Reference_Type (Etype (Orig_Act_1))
then
Actual_2 := Next_Actual (Actual_1);
Formal_2 := Next_Formal (Formal_1);
while Present (Actual_2) and then Present (Formal_2) loop
Orig_Act_2 := Original_Actual (Actual_2);
-- The other actual we are testing against must also denote
-- a non pass-by-value object. Generate the check only when
-- the mode of the two formals may lead to aliasing.
if Is_Object_Reference (Original_Actual (Actual_2))
and then not
Is_Elementary_Type (Etype (Original_Actual (Actual_2)))
if Is_Object_Reference (Orig_Act_2)
and then not Is_Elementary_Type (Etype (Orig_Act_2))
and then May_Cause_Aliasing (Formal_1, Formal_2)
then
Overlap_Check

6
gcc/ada/exp_aggr.adb
View File

@ -354,10 +354,16 @@ package body Exp_Aggr is
Siz : constant Nat := Component_Count (Component_Type (T));
begin
-- Check for superflat arrays, i.e. arrays with such bounds
-- as 4 .. 2, to insure that this function never returns a
-- meaningless negative value.
if not Compile_Time_Known_Value (Lo)
or else not Compile_Time_Known_Value (Hi)
or else Expr_Value (Hi) < Expr_Value (Lo)
then
return 0;
else
return
Siz * UI_To_Int (Expr_Value (Hi) - Expr_Value (Lo) + 1);

10
gcc/ada/freeze.adb
View File

@ -3288,12 +3288,14 @@ package body Freeze is
if Ekind (E) = E_Function then
-- Check whether function is declared elsewhere.
-- Check whether function is declared elsewhere. Previous code
-- used Get_Source_Unit on both arguments, but the values are
-- equal in the case of a parent and a child unit.
-- Confusion with subunits in code ????
Late_Freezing :=
Get_Source_Unit (E) /= Get_Source_Unit (N)
and then Returns_Limited_View (E)
and then not In_Open_Scopes (Scope (E));
not In_Same_Extended_Unit (E, N)
and then Returns_Limited_View (E);
-- Freeze return type

5
gcc/ada/sem_attr.adb
View File

@ -10094,11 +10094,10 @@ package body Sem_Attr is
Freeze_Before (N, Entity (P));
end if;
-- If it is a type, there is nothing to resolve.
-- If it is an object, complete its resolution.
-- If it is a type, there is nothing to resolve. If it is an
-- object, complete its resolution.
elsif Is_Overloadable (Entity (P)) then
if not In_Spec_Expression then
Freeze_Before (N, Entity (P));
end if;

4
gcc/ada/sem_res.adb
View File

@ -6963,8 +6963,8 @@ package body Sem_Res is
then
null;
else
Error_Msg_N (
"deferred constant is frozen before completion", N);
Error_Msg_N
("deferred constant is frozen before completion", N);
end if;
end if;

28
gcc/ada/sem_util.adb
View File

@ -13103,9 +13103,9 @@ package body Sem_Util is
Par := Nod;
while Present (Par) loop
if Nkind_In (Par, N_Function_Call,
N_Procedure_Call_Statement,
N_Entry_Call_Statement)
if Nkind_In (Par, N_Entry_Call_Statement,
N_Function_Call,
N_Procedure_Call_Statement)
then
return True;
@ -15978,22 +15978,20 @@ package body Sem_Util is
if New_Sloc /= No_Location then
Set_Sloc (New_Node, New_Sloc);
-- If we adjust the Sloc, then we are essentially making
-- a completely new node, so the Comes_From_Source flag
-- should be reset to the proper default value.
Set_Comes_From_Source (New_Node,
Default_Node.Comes_From_Source);
-- If we adjust the Sloc, then we are essentially making a
-- completely new node, so the Comes_From_Source flag should
-- be reset to the proper default value.
Set_Comes_From_Source
(New_Node, Default_Node.Comes_From_Source);
end if;
-- If the node is call and has named associations,
-- set the corresponding links in the copy.
-- If the node is a call and has named associations, set the
-- corresponding links in the copy.
if (Nkind (Old_Node) = N_Function_Call
or else Nkind (Old_Node) = N_Entry_Call_Statement
or else
Nkind (Old_Node) = N_Procedure_Call_Statement)
if Nkind_In (Old_Node, N_Entry_Call_Statement,
N_Function_Call,
N_Procedure_Call_Statement)
and then Present (First_Named_Actual (Old_Node))
then
Adjust_Named_Associations (Old_Node, New_Node);