From 5f49133f81390b80edb508542edaa91583c9628a Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 2 Oct 2012 10:13:09 +0200 Subject: [PATCH] [multiple changes] 2012-10-02 Vincent Pucci * 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 * 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 --- gcc/ada/ChangeLog | 27 +++++++ gcc/ada/checks.adb | 203 ++++++++++++++++++++++++++++++++++++++++------------ gcc/ada/checks.ads | 12 +++- gcc/ada/exp_ch6.adb | 8 +++ gcc/ada/freeze.adb | 8 +-- gcc/ada/sem_ch4.adb | 2 + gcc/ada/sem_ch6.adb | 4 ++ gcc/ada/sem_dim.adb | 29 +++++--- gcc/ada/sem_dim.ads | 5 +- 9 files changed, 234 insertions(+), 64 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index fa0c515..addb48f 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,30 @@ +2012-10-02 Vincent Pucci + + * 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 + + * 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 * sem_ch4.adb (Is_Empty_Range): Use bounds of index type diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 5923c83..7810421 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -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 Apply_Parameter_Aliasing_Checks + (Call : Node_Id; + Subp : Entity_Id) + is + function May_Cause_Aliasing + (Formal_1 : Entity_Id; + Formal_2 : Entity_Id) return Boolean; + -- Determine whether two formal parameters can alias each other + -- depending on their modes. - procedure Add_Aliasing_Check + 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); - -- 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 + 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; @@ -2066,24 +2214,6 @@ package body Checks is -- 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 -- diff --git a/gcc/ada/checks.ads b/gcc/ada/checks.ads index 583d558..a43fff7 100644 --- a/gcc/ada/checks.ads +++ b/gcc/ada/checks.ads @@ -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 diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index fe01e34..02d504a 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -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 diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 03b2759..02f6f53 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -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 diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index ef13222..34e5e52 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -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; ------------------------ diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 6d82598..dd2a8b8 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -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; ----------------------------- diff --git a/gcc/ada/sem_dim.adb b/gcc/ada/sem_dim.adb index 15b32dc..0d41bda 100644 --- a/gcc/ada/sem_dim.adb +++ b/gcc/ada/sem_dim.adb @@ -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 diff --git a/gcc/ada/sem_dim.ads b/gcc/ada/sem_dim.ads index d069df9..7ce4e59 100644 --- a/gcc/ada/sem_dim.ads +++ b/gcc/ada/sem_dim.ads @@ -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; -- 2.7.4