sem_aggr.adb (Aggregate_Constraint_Checks): Apply a conversion to the expression...

2005-06-14  Gary Dismukes  <dismukes@adacore.com>

	* sem_aggr.adb (Aggregate_Constraint_Checks): Apply a conversion to the
	expression when the component type is an anonymous access type to
	ensure that appropriate accessibility checks are done.

	* sem_ch5.adb (Analyze_Assignment): Apply a implicit conversion to the
	expression of an assignment when the target object is of an anonymous
	access type. This ensures that required accessibility checks are done.
	(One_Bound): Move the check for type Universal_Integer to
	Process_Bounds.
	(Process_Bounds): Check whether the type of the preanalyzed range is
	Universal_Integer, and in that case set Typ to Integer_Type prior
	to setting the type of the original range and the calls to One_Bound.

From-SVN: r101057

diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb
index aa7cddff6a17100da162dbd74e8f05edc4bda746..8c5d7f9b4ffbbe1afaa1838b24a5244e3a3b3fe4 100644 (file)
--- a/gcc/ada/sem_aggr.adb
+++ b/gcc/ada/sem_aggr.adb
@@ -468,12 +468,16 @@ package body Sem_Aggr is
             Check_Unset_Reference (Exp);
          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
 
       elsif Is_Access_Type (Check_Typ)
-        and then Can_Never_Be_Null (Check_Typ)
-        and then not Can_Never_Be_Null (Exp_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);
@@ -543,7 +547,7 @@ package body Sem_Aggr is
 
                elsif Expr_Value (This_Low) /= Expr_Value (Aggr_Low (Dim)) then
                   Set_Raises_Constraint_Error (N);
-                  Error_Msg_N ("Sub-aggregate low bound mismatch?", N);
+                  Error_Msg_N ("sub-aggregate low bound mismatch?", N);
                   Error_Msg_N ("Constraint_Error will be raised at run-time?",
                                N);
                end if;
@@ -557,7 +561,7 @@ package body Sem_Aggr is
                  Expr_Value (This_High) /= Expr_Value (Aggr_High (Dim))
                then
                   Set_Raises_Constraint_Error (N);
-                  Error_Msg_N ("Sub-aggregate high bound mismatch?", N);
+                  Error_Msg_N ("sub-aggregate high bound mismatch?", N);
                   Error_Msg_N ("Constraint_Error will be raised at run-time?",
                                N);
                end if;
@@ -1301,7 +1305,7 @@ package body Sem_Aggr is
 
          if Range_Len < Len then
             Set_Raises_Constraint_Error (N);
-            Error_Msg_N ("Too many elements?", N);
+            Error_Msg_N ("too many elements?", N);
             Error_Msg_N ("Constraint_Error will be raised at run-time?", N);
          end if;
       end Check_Length;
@@ -1392,7 +1396,7 @@ package body Sem_Aggr is
                   --  aggregate must not be enclosed in parentheses.
 
                   if Paren_Count (Expr) /= 0 then
-                     Error_Msg_N ("No parenthesis allowed here", Expr);
+                     Error_Msg_N ("no parenthesis allowed here", Expr);
                   end if;
 
                   Make_String_Into_Aggregate (Expr);

diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb
index 163365fc46a3f1577eef6c6a146d7bd547263f4c..6d9bcaa4ff9cbe0420d4a15be83ca8a3e6e09f55 100644 (file)
--- a/gcc/ada/sem_ch5.adb
+++ b/gcc/ada/sem_ch5.adb
@@ -400,6 +400,17 @@ package body Sem_Ch5 is
          Propagate_Tag (Lhs, Rhs);
       end if;
 
+      --  Ada 2005 (AI-230 and AI-385): When the lhs type is an anonymous
+      --  access type, apply an implicit conversion of the rhs to that type
+      --  to force appropriate static and run-time accessibility checks.
+
+      if Ada_Version >= Ada_05
+        and then Ekind (T1) = E_Anonymous_Access_Type
+      then
+         Rewrite (Rhs, Convert_To (T1, Relocate_Node (Rhs)));
+         Analyze_And_Resolve (Rhs, T1);
+      end if;
+
       --  Ada 2005 (AI-231)
 
       if Ada_Version >= Ada_05
@@ -1151,10 +1162,9 @@ package body Sem_Ch5 is
            (Original_Bound : Node_Id;
             Analyzed_Bound : Node_Id) return Node_Id
          is
-            Assign   : Node_Id;
-            Id       : Entity_Id;
-            Decl     : Node_Id;
-            Decl_Typ : Entity_Id;
+            Assign : Node_Id;
+            Id     : Entity_Id;
+            Decl   : Node_Id;
 
          begin
             --  If the bound is a constant or an object, no need for a
@@ -1181,20 +1191,10 @@ package body Sem_Ch5 is
               Make_Defining_Identifier (Loc,
                 Chars => New_Internal_Name ('S'));
 
-            --  If the type of the discrete range is Universal_Integer, then
-            --  the bound's type must be resolved to Integer, so the object
-            --  used to hold the bound must also have type Integer.
-
-            if Typ = Universal_Integer then
-               Decl_Typ := Standard_Integer;
-            else
-               Decl_Typ := Typ;
-            end if;
-
             Decl :=
               Make_Object_Declaration (Loc,
                 Defining_Identifier => Id,
-                Object_Definition   => New_Occurrence_Of (Decl_Typ, Loc));
+                Object_Definition   => New_Occurrence_Of (Typ, Loc));
 
             Insert_Before (Parent (N), Decl);
             Analyze (Decl);
@@ -1224,6 +1224,15 @@ package body Sem_Ch5 is
          Set_Parent (R_Copy, Parent (R));
          Pre_Analyze_And_Resolve (R_Copy);
          Typ := Etype (R_Copy);
+
+         --  If the type of the discrete range is Universal_Integer, then
+         --  the bound's type must be resolved to Integer, and any object
+         --  used to hold the bound must also have type Integer.
+
+         if Typ = Universal_Integer then
+            Typ := Standard_Integer;
+         end if;
+
          Set_Etype (R, Typ);
 
          New_Lo_Bound := One_Bound (Lo, Low_Bound  (R_Copy));