[multiple changes]
2012-10-02 Vincent Pucci <pucci@adacore.com> * sem_ch4.adb (Analyze_Indexed_Component_Form): Dimension analysis for indexed components added. * sem_ch6.adb (Analyze_Function_Call): Dimension propagation for function calls added. * sem_dim.adb (Analyze_Dimension): Call to Analyze_Dimension_Has_Etype when N is a function call. (Analyze_Dimension_Call): Don't propagate anymore the dimensions for function calls since this is now treated separately in Analyze_Dimension_Has_Etype. (Analyze_Dimension_Has_Etype): For attribute references, propagate the dimensions from the prefix. * sem_dim.ads (Copy_Dimensions): Fix comment. 2012-10-02 Hristian Kirtchev <kirtchev@adacore.com> * checks.ads, checks.adb (Apply_Parameter_Aliasing_Checks): New routine. (Apply_Parameter_Aliasing_And_Validity_Checks): This routine has been split into two. (Apply_Parameter_Validity_Checks): New routine. * exp_ch6.adb (Expand_Call): Add checks to verify that actuals do not overlap. The checks are made on the caller side to overcome issues of parameter passing mechanisms. * freeze.adb (Freeze_Entity): Update call to Apply_Parameter_Aliasing_And_Validity_Checks. From-SVN: r191959
This commit is contained in:
Arnaud Charlet
parent
4856cc2a7d
commit
5f49133f81
|
|
@ -1,3 +1,30 @@
|
|||
2012-10-02 Vincent Pucci <pucci@adacore.com>
|
||||
|
||||
* sem_ch4.adb (Analyze_Indexed_Component_Form): Dimension
|
||||
analysis for indexed components added.
|
||||
* sem_ch6.adb (Analyze_Function_Call): Dimension propagation
|
||||
for function calls added.
|
||||
* sem_dim.adb (Analyze_Dimension): Call to
|
||||
Analyze_Dimension_Has_Etype when N is a function call.
|
||||
(Analyze_Dimension_Call): Don't propagate anymore the dimensions
|
||||
for function calls since this is now treated separately in
|
||||
Analyze_Dimension_Has_Etype.
|
||||
(Analyze_Dimension_Has_Etype): For
|
||||
attribute references, propagate the dimensions from the prefix.
|
||||
* sem_dim.ads (Copy_Dimensions): Fix comment.
|
||||
|
||||
2012-10-02 Hristian Kirtchev <kirtchev@adacore.com>
|
||||
|
||||
* checks.ads, checks.adb (Apply_Parameter_Aliasing_Checks): New routine.
|
||||
(Apply_Parameter_Aliasing_And_Validity_Checks): This routine
|
||||
has been split into two.
|
||||
(Apply_Parameter_Validity_Checks): New routine.
|
||||
* exp_ch6.adb (Expand_Call): Add checks to verify that actuals
|
||||
do not overlap. The checks are made on the caller side to overcome
|
||||
issues of parameter passing mechanisms.
|
||||
* freeze.adb (Freeze_Entity): Update call to
|
||||
Apply_Parameter_Aliasing_And_Validity_Checks.
|
||||
|
||||
2012-10-02 Ed Schonberg <schonberg@adacore.com>
|
||||
|
||||
* sem_ch4.adb (Is_Empty_Range): Use bounds of index type
|
||||
|
|
|
|||
|
|
@ -2040,18 +2040,166 @@ package body Checks is
|
|||
(Ck_Node, Target_Typ, Source_Typ, Do_Static => False);
|
||||
end Apply_Length_Check;
|
||||
|
||||
--------------------------------------------------
|
||||
-- Apply_Parameter_Aliasing_And_Validity_Checks --
|
||||
--------------------------------------------------
|
||||
-------------------------------------
|
||||
-- Apply_Parameter_Aliasing_Checks --
|
||||
-------------------------------------
|
||||
|
||||
procedure Apply_Parameter_Aliasing_And_Validity_Checks (Subp : Entity_Id) is
|
||||
Subp_Decl : Node_Id;
|
||||
|
||||
procedure Add_Aliasing_Check
|
||||
procedure Apply_Parameter_Aliasing_Checks
|
||||
(Call : Node_Id;
|
||||
Subp : Entity_Id)
|
||||
is
|
||||
function May_Cause_Aliasing
|
||||
(Formal_1 : Entity_Id;
|
||||
Formal_2 : Entity_Id);
|
||||
-- Add a single 'Overlapping_Storage check to a post condition pragma
|
||||
-- which verifies that Formal_1 is not aliasing Formal_2.
|
||||
Formal_2 : Entity_Id) return Boolean;
|
||||
-- Determine whether two formal parameters can alias each other
|
||||
-- depending on their modes.
|
||||
|
||||
function Original_Actual (N : Node_Id) return Node_Id;
|
||||
-- The expander may replace an actual with a temporary for the sake of
|
||||
-- side effect removal. The temporary may hide a potential aliasing as
|
||||
-- it does not share the address of the actual. This routine attempts
|
||||
-- to retrieve the original actual.
|
||||
|
||||
------------------------
|
||||
-- May_Cause_Aliasing --
|
||||
------------------------
|
||||
|
||||
function May_Cause_Aliasing
|
||||
(Formal_1 : Entity_Id;
|
||||
Formal_2 : Entity_Id) return Boolean
|
||||
is
|
||||
begin
|
||||
-- The following combination cannot lead to aliasing
|
||||
|
||||
-- Formal 1 Formal 2
|
||||
-- IN IN
|
||||
|
||||
if Ekind (Formal_1) = E_In_Parameter
|
||||
and then Ekind (Formal_2) = E_In_Parameter
|
||||
then
|
||||
return False;
|
||||
|
||||
-- The following combinations may lead to aliasing
|
||||
|
||||
-- Formal 1 Formal 2
|
||||
-- IN OUT
|
||||
-- IN IN OUT
|
||||
-- OUT IN
|
||||
-- OUT IN OUT
|
||||
-- OUT OUT
|
||||
|
||||
else
|
||||
return True;
|
||||
end if;
|
||||
end May_Cause_Aliasing;
|
||||
|
||||
---------------------
|
||||
-- Original_Actual --
|
||||
---------------------
|
||||
|
||||
function Original_Actual (N : Node_Id) return Node_Id is
|
||||
begin
|
||||
if Nkind (N) = N_Type_Conversion then
|
||||
return Expression (N);
|
||||
|
||||
-- The expander created a temporary to capture the result of a type
|
||||
-- conversion where the expression is the real actual.
|
||||
|
||||
elsif Nkind (N) = N_Identifier
|
||||
and then Present (Original_Node (N))
|
||||
and then Nkind (Original_Node (N)) = N_Type_Conversion
|
||||
then
|
||||
return Expression (Original_Node (N));
|
||||
end if;
|
||||
|
||||
return N;
|
||||
end Original_Actual;
|
||||
|
||||
-- Local variables
|
||||
|
||||
Loc : constant Source_Ptr := Sloc (Call);
|
||||
Actual_1 : Node_Id;
|
||||
Actual_2 : Node_Id;
|
||||
Check : Node_Id;
|
||||
Cond : Node_Id;
|
||||
Formal_1 : Entity_Id;
|
||||
Formal_2 : Entity_Id;
|
||||
|
||||
-- Start of processing for Apply_Parameter_Aliasing_Checks
|
||||
|
||||
begin
|
||||
Cond := Empty;
|
||||
|
||||
Actual_1 := First_Actual (Call);
|
||||
Formal_1 := First_Formal (Subp);
|
||||
while Present (Actual_1) and then Present (Formal_1) loop
|
||||
|
||||
-- Ensure that the actual is an object that is not passed by value.
|
||||
-- Elementary types are always passed by value, therefore actuals of
|
||||
-- such types cannot lead to aliasing.
|
||||
|
||||
if Is_Object_Reference (Original_Actual (Actual_1))
|
||||
and then not Is_Elementary_Type (Etype (Original_Actual (Actual_1)))
|
||||
then
|
||||
Actual_2 := Next_Actual (Actual_1);
|
||||
Formal_2 := Next_Formal (Formal_1);
|
||||
while Present (Actual_2) and then Present (Formal_2) loop
|
||||
|
||||
-- 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)))
|
||||
and then May_Cause_Aliasing (Formal_1, Formal_2)
|
||||
then
|
||||
-- Generate:
|
||||
-- Actual_1'Overlaps_Storage (Actual_2)
|
||||
|
||||
Check :=
|
||||
Make_Attribute_Reference (Loc,
|
||||
Prefix =>
|
||||
New_Copy_Tree (Original_Actual (Actual_1)),
|
||||
Attribute_Name => Name_Overlaps_Storage,
|
||||
Expressions =>
|
||||
New_List (New_Copy_Tree (Original_Actual (Actual_2))));
|
||||
|
||||
if No (Cond) then
|
||||
Cond := Check;
|
||||
else
|
||||
Cond :=
|
||||
Make_And_Then (Loc,
|
||||
Left_Opnd => Cond,
|
||||
Right_Opnd => Check);
|
||||
end if;
|
||||
end if;
|
||||
|
||||
Next_Actual (Actual_2);
|
||||
Next_Formal (Formal_2);
|
||||
end loop;
|
||||
end if;
|
||||
|
||||
Next_Actual (Actual_1);
|
||||
Next_Formal (Formal_1);
|
||||
end loop;
|
||||
|
||||
-- Place the check right before the call
|
||||
|
||||
if Present (Cond) then
|
||||
Insert_Action (Call,
|
||||
Make_Raise_Program_Error (Loc,
|
||||
Condition => Cond,
|
||||
Reason => PE_Explicit_Raise));
|
||||
end if;
|
||||
end Apply_Parameter_Aliasing_Checks;
|
||||
|
||||
-------------------------------------
|
||||
-- Apply_Parameter_Validity_Checks --
|
||||
-------------------------------------
|
||||
|
||||
procedure Apply_Parameter_Validity_Checks (Subp : Entity_Id) is
|
||||
Subp_Decl : Node_Id;
|
||||
|
||||
procedure Add_Validity_Check
|
||||
(Context : Entity_Id;
|
||||
|
|
@ -2065,24 +2213,6 @@ package body Checks is
|
|||
-- Create a pre or post condition pragma with name PPC_Nam which
|
||||
-- tests expression Check.
|
||||
|
||||
------------------------
|
||||
-- Add_Aliasing_Check --
|
||||
------------------------
|
||||
|
||||
procedure Add_Aliasing_Check
|
||||
(Formal_1 : Entity_Id;
|
||||
Formal_2 : Entity_Id)
|
||||
is
|
||||
Loc : constant Source_Ptr := Sloc (Subp);
|
||||
|
||||
begin
|
||||
Build_PPC_Pragma (Name_Postcondition,
|
||||
Make_Attribute_Reference (Loc,
|
||||
Prefix => New_Reference_To (Formal_1, Loc),
|
||||
Attribute_Name => Name_Overlaps_Storage,
|
||||
Expressions => New_List (New_Reference_To (Formal_2, Loc))));
|
||||
end Add_Aliasing_Check;
|
||||
|
||||
------------------------
|
||||
-- Add_Validity_Check --
|
||||
------------------------
|
||||
|
|
@ -2204,10 +2334,9 @@ package body Checks is
|
|||
-- Local variables
|
||||
|
||||
Formal : Entity_Id;
|
||||
Pair : Entity_Id;
|
||||
Subp_Spec : Node_Id;
|
||||
|
||||
-- Start of processing for Apply_Parameter_Aliasing_And_Validity_Checks
|
||||
-- Start of processing for Apply_Parameter_Validity_Checks
|
||||
|
||||
begin
|
||||
-- Extract the subprogram specification and declaration nodes
|
||||
|
|
@ -2274,20 +2403,6 @@ package body Checks is
|
|||
end if;
|
||||
end if;
|
||||
|
||||
-- Generate the following aliasing checks for every pair of formal
|
||||
-- parameters:
|
||||
|
||||
-- Formal'Overlapping_Storage (Pair)
|
||||
|
||||
if Check_Aliasing_Of_Parameters then
|
||||
Pair := Next_Formal (Formal);
|
||||
while Present (Pair) loop
|
||||
Add_Aliasing_Check (Formal, Pair);
|
||||
|
||||
Next_Formal (Pair);
|
||||
end loop;
|
||||
end if;
|
||||
|
||||
Next_Formal (Formal);
|
||||
end loop;
|
||||
|
||||
|
|
@ -2301,7 +2416,7 @@ package body Checks is
|
|||
then
|
||||
Add_Validity_Check (Subp, Name_Postcondition, True);
|
||||
end if;
|
||||
end Apply_Parameter_Aliasing_And_Validity_Checks;
|
||||
end Apply_Parameter_Validity_Checks;
|
||||
|
||||
---------------------------
|
||||
-- Apply_Predicate_Check --
|
||||
|
|
|
|||
|
|
@ -173,10 +173,16 @@ package Checks is
|
|||
-- occur in the signed case for the case of the largest negative number
|
||||
-- divided by minus one.
|
||||
|
||||
procedure Apply_Parameter_Aliasing_And_Validity_Checks (Subp : Entity_Id);
|
||||
procedure Apply_Parameter_Aliasing_Checks
|
||||
(Call : Node_Id;
|
||||
Subp : Entity_Id);
|
||||
-- Given a subprogram call Call, add a check to verify that none of the
|
||||
-- actuals overlap. Subp denotes the subprogram being called.
|
||||
|
||||
procedure Apply_Parameter_Validity_Checks (Subp : Entity_Id);
|
||||
-- Given a subprogram Subp, add both a pre and post condition pragmas that
|
||||
-- detect aliased objects and verify the proper initialization of scalars
|
||||
-- in parameters and function results.
|
||||
-- verify the proper initialization of scalars in parameters and function
|
||||
-- results.
|
||||
|
||||
procedure Apply_Predicate_Check (N : Node_Id; Typ : Entity_Id);
|
||||
-- N is an expression to which a predicate check may need to be applied
|
||||
|
|
|
|||
|
|
@ -3400,6 +3400,14 @@ package body Exp_Ch6 is
|
|||
|
||||
Expand_Actuals (Call_Node, Subp);
|
||||
|
||||
-- Verify that the actuals do not share storage. This check must be done
|
||||
-- on the caller side rather that inside the subprogram to avoid issues
|
||||
-- of parameter passing.
|
||||
|
||||
if Check_Aliasing_Of_Parameters then
|
||||
Apply_Parameter_Aliasing_Checks (Call_Node, Subp);
|
||||
end if;
|
||||
|
||||
-- If the subprogram is a renaming, or if it is inherited, replace it in
|
||||
-- the call with the name of the actual subprogram being called. If this
|
||||
-- is a dispatching call, the run-time decides what to call. The Alias
|
||||
|
|
|
|||
|
|
@ -2656,13 +2656,13 @@ package body Freeze is
|
|||
end;
|
||||
end if;
|
||||
|
||||
-- Add checks to detect proper initialization of scalars and overlapping
|
||||
-- storage of subprogram parameters.
|
||||
-- Add checks to detect proper initialization of scalars that may appear
|
||||
-- as subprogram parameters.
|
||||
|
||||
if Is_Subprogram (E)
|
||||
and then (Check_Aliasing_Of_Parameters or Check_Validity_Of_Parameters)
|
||||
and then Check_Validity_Of_Parameters
|
||||
then
|
||||
Apply_Parameter_Aliasing_And_Validity_Checks (E);
|
||||
Apply_Parameter_Validity_Checks (E);
|
||||
end if;
|
||||
|
||||
-- Deal with delayed aspect specifications. The analysis of the
|
||||
|
|
|
|||
|
|
@ -2386,6 +2386,8 @@ package body Sem_Ch4 is
|
|||
Process_Indexed_Component_Or_Slice;
|
||||
end if;
|
||||
end if;
|
||||
|
||||
Analyze_Dimension (N);
|
||||
end Analyze_Indexed_Component_Form;
|
||||
|
||||
------------------------
|
||||
|
|
|
|||
|
|
@ -500,6 +500,10 @@ package body Sem_Ch6 is
|
|||
end if;
|
||||
|
||||
Analyze_Call (N);
|
||||
|
||||
-- Propagate the dimensions from the returned type, if necessary
|
||||
|
||||
Analyze_Dimension (N);
|
||||
end Analyze_Function_Call;
|
||||
|
||||
-----------------------------
|
||||
|
|
|
|||
|
|
@ -1154,6 +1154,7 @@ package body Sem_Dim is
|
|||
|
||||
when N_Attribute_Reference |
|
||||
N_Expanded_Name |
|
||||
N_Function_Call |
|
||||
N_Identifier |
|
||||
N_Indexed_Component |
|
||||
N_Qualified_Expression |
|
||||
|
|
@ -1651,13 +1652,6 @@ package body Sem_Dim is
|
|||
Next_Actual (Actual);
|
||||
Next_Formal (Formal);
|
||||
end loop;
|
||||
|
||||
-- For function calls, propagate the dimensions from the returned type
|
||||
-- to the function call.
|
||||
|
||||
if Nkind (N) = N_Function_Call then
|
||||
Analyze_Dimension_Has_Etype (N);
|
||||
end if;
|
||||
end Analyze_Dimension_Call;
|
||||
|
||||
---------------------------------------------
|
||||
|
|
@ -1913,21 +1907,34 @@ package body Sem_Dim is
|
|||
|
||||
procedure Analyze_Dimension_Has_Etype (N : Node_Id) is
|
||||
Etyp : constant Entity_Id := Etype (N);
|
||||
Dims_Of_Etyp : constant Dimension_Type := Dimensions_Of (Etyp);
|
||||
Dims_Of_Etyp : Dimension_Type := Dimensions_Of (Etyp);
|
||||
|
||||
begin
|
||||
-- Propagation of the dimensions from the type
|
||||
-- General case. Propagation of the dimensions from the type
|
||||
|
||||
if Exists (Dims_Of_Etyp) then
|
||||
Set_Dimensions (N, Dims_Of_Etyp);
|
||||
|
||||
-- Propagation of the dimensions from the entity for identifier whose
|
||||
-- entity is a non-dimensionless consant.
|
||||
-- Identifier case. Propagate the dimensions from the entity for
|
||||
-- identifier whose entity is a non-dimensionless consant.
|
||||
|
||||
elsif Nkind (N) = N_Identifier
|
||||
and then Exists (Dimensions_Of (Entity (N)))
|
||||
then
|
||||
Set_Dimensions (N, Dimensions_Of (Entity (N)));
|
||||
|
||||
-- Attribute reference case. Propagate the dimensions from the prefix.
|
||||
|
||||
elsif Nkind (N) = N_Attribute_Reference
|
||||
and then Has_Dimension_System (Base_Type (Etyp))
|
||||
then
|
||||
Dims_Of_Etyp := Dimensions_Of (Prefix (N));
|
||||
|
||||
-- Check the prefix is not dimensionless
|
||||
|
||||
if Exists (Dims_Of_Etyp) then
|
||||
Set_Dimensions (N, Dims_Of_Etyp);
|
||||
end if;
|
||||
end if;
|
||||
|
||||
-- Removal of dimensions in expression
|
||||
|
|
|
|||
|
|
@ -163,8 +163,9 @@ package Sem_Dim is
|
|||
-- literal default value in the list of formals Formals.
|
||||
|
||||
procedure Copy_Dimensions (From, To : Node_Id);
|
||||
-- Copy dimension vector of From to To
|
||||
-- We should say what the requirements on From and To are here ???
|
||||
-- Copy dimension vector of node From to node To. Note that To must be a
|
||||
-- node that is allowed to contain a dimension. (See OK_For_Dimension in
|
||||
-- body of Sem_Dim).
|
||||
|
||||
procedure Eval_Op_Expon_For_Dimensioned_Type
|
||||
(N : Node_Id;
|
||||
|
|
|
|||
Loading…
Reference in New Issue