sem_aggr.adb (Aggregate_Constraint_Checks): Moved to sem_util.

2014-07-18  Ed Schonberg  <schonberg@adacore.com>

	* sem_aggr.adb (Aggregate_Constraint_Checks): Moved to sem_util.
	* sem_util.ads, sem_util.adb (Aggregate_Constraint_Checks):
	Moved here, so it can be shared with the resolution of 'Update,
	whose argument shares some features with aggregates.
	* sem_attr.adb (Resolve_Attribute, case 'Update): Apply
	Aggregate_Constraint_Checks with the expression of each
	association, so that the Do_Range_Check flag is set when needed.

2014-07-18  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch4.adb (Try_Container_Indexing):  If the container
	type is a derived type, the value of the inherited  aspect is
	the Reference operation declared for the parent type. However,
	Reference is also a primitive operation of the new type, and
	the inherited operation has a different signature. We retrieve
	the right one from the list of primitive operations of the
	derived type.

From-SVN: r212786

6 files changed, 164 insertions, 125 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 8641503..cb343c8 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,23 @@
+2014-07-18  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_aggr.adb (Aggregate_Constraint_Checks): Moved to sem_util.
+	* sem_util.ads, sem_util.adb (Aggregate_Constraint_Checks):
+	Moved here, so it can be shared with the resolution of 'Update,
+	whose argument shares some features with aggregates.
+	* sem_attr.adb (Resolve_Attribute, case 'Update): Apply
+	Aggregate_Constraint_Checks with the expression of each
+	association, so that the Do_Range_Check flag is set when needed.
+
+2014-07-18  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_ch4.adb (Try_Container_Indexing):  If the container
+	type is a derived type, the value of the inherited  aspect is
+	the Reference operation declared for the parent type. However,
+	Reference is also a primitive operation of the new type, and
+	the inherited operation has a different signature. We retrieve
+	the right one from the list of primitive operations of the
+	derived type.
+
 2014-07-18  Vincent Celier  <celier@adacore.com>
 
 	* debug.adb: Update comment.
diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb
index df24ba2..0a27239 100644
--- a/gcc/ada/sem_aggr.adb
+++ b/gcc/ada/sem_aggr.adb
@@ -408,134 +408,11 @@ package body Sem_Aggr is
    --  The bounds of the aggregate itype are cooked up to look reasonable
    --  (in this particular case the bounds will be 1 .. 2).
 
-   procedure Aggregate_Constraint_Checks
-     (Exp       : Node_Id;
-      Check_Typ : Entity_Id);
-   --  Checks expression Exp against subtype Check_Typ. If Exp is an
-   --  aggregate and Check_Typ a constrained record type with discriminants,
-   --  we generate the appropriate discriminant checks. If Exp is an array
-   --  aggregate then emit the appropriate length checks. If Exp is a scalar
-   --  type, or a string literal, Exp is changed into Check_Typ'(Exp) to
-   --  ensure that range checks are performed at run time.
-
    procedure Make_String_Into_Aggregate (N : Node_Id);
    --  A string literal can appear in  a context in  which a one dimensional
    --  array of characters is expected. This procedure simply rewrites the
    --  string as an aggregate, prior to resolution.
 
-   ---------------------------------
-   -- Aggregate_Constraint_Checks --
-   ---------------------------------
-
-   procedure Aggregate_Constraint_Checks
-     (Exp       : Node_Id;
-      Check_Typ : Entity_Id)
-   is
-      Exp_Typ : constant Entity_Id  := Etype (Exp);
-
-   begin
-      if Raises_Constraint_Error (Exp) then
-         return;
-      end if;
-
-      --  Ada 2005 (AI-230): Generate a conversion to an anonymous access
-      --  component's type to force the appropriate accessibility checks.
-
-      --  Ada 2005 (AI-231): Generate conversion to the null-excluding
-      --  type to force the corresponding run-time check
-
-      if Is_Access_Type (Check_Typ)
-        and then ((Is_Local_Anonymous_Access (Check_Typ))
-                    or else (Can_Never_Be_Null (Check_Typ)
-                               and then not Can_Never_Be_Null (Exp_Typ)))
-      then
-         Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp)));
-         Analyze_And_Resolve (Exp, Check_Typ);
-         Check_Unset_Reference (Exp);
-      end if;
-
-      --  This is really expansion activity, so make sure that expansion is
-      --  on and is allowed. In GNATprove mode, we also want check flags to
-      --  be added in the tree, so that the formal verification can rely on
-      --  those to be present. In GNATprove mode for formal verification, some
-      --  treatment typically only done during expansion needs to be performed
-      --  on the tree, but it should not be applied inside generics. Otherwise,
-      --  this breaks the name resolution mechanism for generic instances.
-
-      if not Expander_Active
-        and (Inside_A_Generic or not Full_Analysis or not GNATprove_Mode)
-      then
-         return;
-      end if;
-
-      --  First check if we have to insert discriminant checks
-
-      if Has_Discriminants (Exp_Typ) then
-         Apply_Discriminant_Check (Exp, Check_Typ);
-
-      --  Next emit length checks for array aggregates
-
-      elsif Is_Array_Type (Exp_Typ) then
-         Apply_Length_Check (Exp, Check_Typ);
-
-      --  Finally emit scalar and string checks. If we are dealing with a
-      --  scalar literal we need to check by hand because the Etype of
-      --  literals is not necessarily correct.
-
-      elsif Is_Scalar_Type (Exp_Typ)
-        and then Compile_Time_Known_Value (Exp)
-      then
-         if Is_Out_Of_Range (Exp, Base_Type (Check_Typ)) then
-            Apply_Compile_Time_Constraint_Error
-              (Exp, "value not in range of}??", CE_Range_Check_Failed,
-               Ent => Base_Type (Check_Typ),
-               Typ => Base_Type (Check_Typ));
-
-         elsif Is_Out_Of_Range (Exp, Check_Typ) then
-            Apply_Compile_Time_Constraint_Error
-              (Exp, "value not in range of}??", CE_Range_Check_Failed,
-               Ent => Check_Typ,
-               Typ => Check_Typ);
-
-         elsif not Range_Checks_Suppressed (Check_Typ) then
-            Apply_Scalar_Range_Check (Exp, Check_Typ);
-         end if;
-
-      --  Verify that target type is also scalar, to prevent view anomalies
-      --  in instantiations.
-
-      elsif (Is_Scalar_Type (Exp_Typ)
-              or else Nkind (Exp) = N_String_Literal)
-        and then Is_Scalar_Type (Check_Typ)
-        and then Exp_Typ /= Check_Typ
-      then
-         if Is_Entity_Name (Exp)
-           and then Ekind (Entity (Exp)) = E_Constant
-         then
-            --  If expression is a constant, it is worthwhile checking whether
-            --  it is a bound of the type.
-
-            if (Is_Entity_Name (Type_Low_Bound (Check_Typ))
-                 and then Entity (Exp) = Entity (Type_Low_Bound (Check_Typ)))
-              or else (Is_Entity_Name (Type_High_Bound (Check_Typ))
-                and then Entity (Exp) = Entity (Type_High_Bound (Check_Typ)))
-            then
-               return;
-
-            else
-               Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp)));
-               Analyze_And_Resolve (Exp, Check_Typ);
-               Check_Unset_Reference (Exp);
-            end if;
-         else
-            Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp)));
-            Analyze_And_Resolve (Exp, Check_Typ);
-            Check_Unset_Reference (Exp);
-         end if;
-
-      end if;
-   end Aggregate_Constraint_Checks;
-
    ------------------------
    -- Array_Aggr_Subtype --
    ------------------------
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index 8bd19df..5326490 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -10802,6 +10802,7 @@ package body Sem_Attr is
                Typ   : constant Entity_Id := Etype (Prefix (N));
                Assoc : Node_Id;
                Comp  : Node_Id;
+               Expr  : Node_Id;
 
             begin
                --  Set the Etype of the aggregate to that of the prefix, even
@@ -10814,12 +10815,14 @@ package body Sem_Attr is
                Resolve (Prefix (N), Typ);
 
                --  For an array type, resolve expressions with the component
-               --  type of the array.
+               --  type of the array, and apply constraint checks when needed.
 
                if Is_Array_Type (Typ) then
                   Assoc := First (Component_Associations (Aggr));
                   while Present (Assoc) loop
-                     Resolve (Expression (Assoc), Component_Type (Typ));
+                     Expr  := Expression (Assoc);
+                     Resolve (Expr, Component_Type (Typ));
+                     Aggregate_Constraint_Checks (Expr, Component_Type (Typ));
 
                      --  The choices in the association are static constants,
                      --  or static aggregates each of whose components belongs
diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index e45d219..6d0db7d 100644
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -7020,6 +7020,16 @@ package body Sem_Ch4 is
          else
             return False;
          end if;
+
+      --  If the container type is a derived type, the value of the inherited
+      --  aspect is the Reference operation declared for the parent type.
+      --  However, Reference is also a primitive operation of the type, and
+      --  the inherited operation has a different signature. We retrieve the
+      --  right one from the list of primitive operations of the derived type.
+
+      elsif Is_Derived_Type (Etype (Prefix)) then
+         Func := Find_Prim_Op (Etype (Prefix), Chars (Func_Name));
+         Func_Name := New_Occurrence_Of (Func, Loc);
       end if;
 
       Assoc := New_List (Relocate_Node (Prefix));
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 727a994..2c53b51 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -52,6 +52,7 @@ with Sem_Disp; use Sem_Disp;
 with Sem_Eval; use Sem_Eval;
 with Sem_Prag; use Sem_Prag;
 with Sem_Res;  use Sem_Res;
+with Sem_Warn; use Sem_Warn;
 with Sem_Type; use Sem_Type;
 with Sinfo;    use Sinfo;
 with Sinput;   use Sinput;
@@ -474,6 +475,123 @@ package body Sem_Util is
              V = 64;
    end Addressable;
 
+   ---------------------------------
+   -- Aggregate_Constraint_Checks --
+   ---------------------------------
+
+   procedure Aggregate_Constraint_Checks
+     (Exp       : Node_Id;
+      Check_Typ : Entity_Id)
+   is
+      Exp_Typ : constant Entity_Id  := Etype (Exp);
+
+   begin
+      if Raises_Constraint_Error (Exp) then
+         return;
+      end if;
+
+      --  Ada 2005 (AI-230): Generate a conversion to an anonymous access
+      --  component's type to force the appropriate accessibility checks.
+
+      --  Ada 2005 (AI-231): Generate conversion to the null-excluding
+      --  type to force the corresponding run-time check
+
+      if Is_Access_Type (Check_Typ)
+        and then ((Is_Local_Anonymous_Access (Check_Typ))
+                    or else (Can_Never_Be_Null (Check_Typ)
+                              and then not Can_Never_Be_Null (Exp_Typ)))
+      then
+         Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp)));
+         Analyze_And_Resolve (Exp, Check_Typ);
+         Check_Unset_Reference (Exp);
+      end if;
+
+      --  This is really expansion activity, so make sure that expansion is
+      --  on and is allowed. In GNATprove mode, we also want check flags to
+      --  be added in the tree, so that the formal verification can rely on
+      --  those to be present. In GNATprove mode for formal verification, some
+      --  treatment typically only done during expansion needs to be performed
+      --  on the tree, but it should not be applied inside generics. Otherwise,
+      --  this breaks the name resolution mechanism for generic instances.
+
+      if not Expander_Active
+        and (Inside_A_Generic or not Full_Analysis or not GNATprove_Mode)
+      then
+         return;
+      end if;
+
+      --  First check if we have to insert discriminant checks
+
+      if Has_Discriminants (Exp_Typ) then
+         Apply_Discriminant_Check (Exp, Check_Typ);
+
+      --  Next emit length checks for array aggregates
+
+      elsif Is_Array_Type (Exp_Typ) then
+         Apply_Length_Check (Exp, Check_Typ);
+
+      --  Finally emit scalar and string checks. If we are dealing with a
+      --  scalar literal we need to check by hand because the Etype of
+      --  literals is not necessarily correct.
+
+      elsif Is_Scalar_Type (Exp_Typ)
+        and then Compile_Time_Known_Value (Exp)
+      then
+         if Is_Out_Of_Range (Exp, Base_Type (Check_Typ)) then
+            Apply_Compile_Time_Constraint_Error
+              (Exp, "value not in range of}??", CE_Range_Check_Failed,
+               Ent => Base_Type (Check_Typ),
+               Typ => Base_Type (Check_Typ));
+
+         elsif Is_Out_Of_Range (Exp, Check_Typ) then
+            Apply_Compile_Time_Constraint_Error
+              (Exp, "value not in range of}??", CE_Range_Check_Failed,
+               Ent => Check_Typ,
+               Typ => Check_Typ);
+
+         elsif not Range_Checks_Suppressed (Check_Typ) then
+            Apply_Scalar_Range_Check (Exp, Check_Typ);
+         end if;
+
+      --  Verify that target type is also scalar, to prevent view anomalies
+      --  in instantiations.
+
+      elsif (Is_Scalar_Type (Exp_Typ)
+              or else Nkind (Exp) = N_String_Literal)
+        and then Is_Scalar_Type (Check_Typ)
+        and then Exp_Typ /= Check_Typ
+      then
+         if Is_Entity_Name (Exp)
+           and then Ekind (Entity (Exp)) = E_Constant
+         then
+            --  If expression is a constant, it is worthwhile checking whether
+            --  it is a bound of the type.
+
+            if (Is_Entity_Name (Type_Low_Bound (Check_Typ))
+                 and then Entity (Exp) = Entity (Type_Low_Bound (Check_Typ)))
+              or else
+               (Is_Entity_Name (Type_High_Bound (Check_Typ))
+                 and then Entity (Exp) = Entity (Type_High_Bound (Check_Typ)))
+            then
+               return;
+
+            else
+               Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp)));
+               Analyze_And_Resolve (Exp, Check_Typ);
+               Check_Unset_Reference (Exp);
+            end if;
+
+         --  Could use a comment on this case ???
+
+         else
+            Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp)));
+            Analyze_And_Resolve (Exp, Check_Typ);
+            Check_Unset_Reference (Exp);
+         end if;
+
+      end if;
+   end Aggregate_Constraint_Checks;
+
    -----------------------
    -- Alignment_In_Bits --
    -----------------------
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index e90ad18..0dbd73a 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -91,6 +91,17 @@ package Sem_Util is
    --  Returns True if the value of V is the word size of an addressable
    --  factor of the word size (typically 8, 16, 32 or 64).
 
+   procedure Aggregate_Constraint_Checks
+     (Exp       : Node_Id;
+      Check_Typ : Entity_Id);
+   --  Checks expression Exp against subtype Check_Typ. If Exp is an aggregate
+   --  and Check_Typ a constrained record type with discriminants, we generate
+   --  the appropriate discriminant checks. If Exp is an array aggregate then
+   --  emit the appropriate length checks. If Exp is a scalar type, or a string
+   --  literal, Exp is changed into Check_Typ'(Exp) to ensure that range checks
+   --  are performed at run time. Also used for expressions in the argument of
+   --  'Update, which shares some of the features of an aggregate.
+
    function Alignment_In_Bits (E : Entity_Id) return Uint;
    --  If the alignment of the type or object E is currently known to the
    --  compiler, then this function returns the alignment value in bits.