+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
-- 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
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
-- 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
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);
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
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;
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;
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;
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);
projects / gcc.git / commitdiff