[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

gcc/ada/ChangeLog

+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

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 --

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

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

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

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;
 
    ------------------------

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;
 
    -----------------------------

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

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;