sem_ch3.adb: Move Has_Defaulted_Discriminants to sem_util.

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

	* sem_ch3.adb: Move Has_Defaulted_Discriminants to sem_util.
	* sem_ch4.adb (Analyze_Allocator): Defer resolution of expression
	until context type is available.
	* sem_res.adb (Resolve_Allocator): In the case of a qualified
	expression, complete resolution of expression.
	(Check_Aliased_Parameter): New procedure within Resolve_Actuals,
	to apply Ada2012 checks on aliased formals, as well as
	accesibility checks when the context of the call is an allocator
	or a qualified expression.
	* sem_util.ads, sem_util.adb (Has_Defaulted_Discriminants):
	Moved here from sem_ch3.
	(Object_Access_Level): Handle properly aliased formals and
	aggregates.
	* exp_ch6.adb (Expand_Call): Remove check on aliased parameters,
	now properly performed in sem_res (Resolve_Actuals,
	Check_Aliased_Parameter).

From-SVN: r213206

7 files changed, 122 insertions, 36 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index aaf8a14..9f1ccb7 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,22 @@
+2014-07-29  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_ch3.adb: Move Has_Defaulted_Discriminants to sem_util.
+	* sem_ch4.adb (Analyze_Allocator): Defer resolution of expression
+	until context type is available.
+	* sem_res.adb (Resolve_Allocator): In the case of a qualified
+	expression, complete resolution of expression.
+	(Check_Aliased_Parameter): New procedure within Resolve_Actuals,
+	to apply Ada2012 checks on aliased formals, as well as
+	accesibility checks when the context of the call is an allocator
+	or a qualified expression.
+	* sem_util.ads, sem_util.adb (Has_Defaulted_Discriminants):
+	Moved here from sem_ch3.
+	(Object_Access_Level): Handle properly aliased formals and
+	aggregates.
+	* exp_ch6.adb (Expand_Call): Remove check on aliased parameters,
+	now properly performed in sem_res (Resolve_Actuals,
+	Check_Aliased_Parameter).
+
 2014-07-29  Yannick Moy  <moy@adacore.com>
 
 	* debug.adb Enable GNATprove inlining under debug flag -gnatdQ for now.
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index c69136d..de2ded8 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -3138,18 +3138,6 @@ package body Exp_Ch6 is
             end if;
          end if;
 
-         --  For Ada 2012, if a parameter is aliased, the actual must be a
-         --  tagged type or an aliased view of an object.
-
-         if Is_Aliased (Formal)
-           and then not Is_Aliased_View (Actual)
-           and then not Is_Tagged_Type (Etype (Formal))
-         then
-            Error_Msg_NE
-              ("actual for aliased formal& must be aliased object",
-               Actual, Formal);
-         end if;
-
          --  For IN OUT and OUT parameters, ensure that subscripts are valid
          --  since this is a left side reference. We only do this for calls
          --  from the source program since we assume that compiler generated
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 8485879..0a75c5c 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -11252,24 +11252,6 @@ package body Sem_Ch3 is
       Desig_Subtype : Entity_Id := Create_Itype (E_Void, Related_Nod);
       Constraint_OK : Boolean := True;
 
-      function Has_Defaulted_Discriminants (Typ : Entity_Id) return Boolean;
-      --  Simple predicate to test for defaulted discriminants
-      --  Shouldn't this be in sem_util???
-
-      ---------------------------------
-      -- Has_Defaulted_Discriminants --
-      ---------------------------------
-
-      function Has_Defaulted_Discriminants (Typ : Entity_Id) return Boolean is
-      begin
-         return Has_Discriminants (Typ)
-          and then Present (First_Discriminant (Typ))
-          and then Present
-            (Discriminant_Default_Value (First_Discriminant (Typ)));
-      end Has_Defaulted_Discriminants;
-
-   --  Start of processing for Constrain_Access
-
    begin
       if Is_Array_Type (Desig_Type) then
          Constrain_Array (Desig_Subtype, S, Related_Nod, Def_Id, 'P');
diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index 313f6f8..9686197 100644
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -501,8 +501,6 @@ package body Sem_Ch4 is
          Type_Id := Etype (E);
          Set_Directly_Designated_Type (Acc_Type, Type_Id);
 
-         Resolve (Expression (E), Type_Id);
-
          --  Allocators generated by the build-in-place expansion mechanism
          --  are explicitly marked as coming from source but do not need to be
          --  checked for limited initialization. To exclude this case, ensure
@@ -529,10 +527,9 @@ package body Sem_Ch4 is
          --     Wrong_Type (Expression (E), Type_Id);
          --  end if;
 
-         Check_Non_Static_Context (Expression (E));
-
          --  We don't analyze the qualified expression itself because it's
-         --  part of the allocator
+         --  part of the allocator. It is fully analyzed and resolved when
+         --  the allocator is resolved with the context type.
 
          Set_Etype  (E, Type_Id);
 
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 0e73216..c0ae52d 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -2976,6 +2976,10 @@ package body Sem_Res is
       Prev   : Node_Id := Empty;
       Orig_A : Node_Id;
 
+      procedure Check_Aliased_Parameter;
+      --  Check rules on aliased parameters and related accessibility rules
+      --  in (3.10.2 (10.2-10.4)).
+
       procedure Check_Argument_Order;
       --  Performs a check for the case where the actuals are all simple
       --  identifiers that correspond to the formal names, but in the wrong
@@ -3012,6 +3016,70 @@ package body Sem_Res is
       --  This must be determined before the actual is resolved and expanded
       --  because if needed the transient scope must be introduced earlier.
 
+      ------------------------------
+      --  Check_Aliased_Parameter --
+      ------------------------------
+
+      procedure Check_Aliased_Parameter is
+         Nominal_Subt : Entity_Id;
+
+      begin
+         if Is_Aliased (F) then
+            if Is_Tagged_Type (A_Typ) then
+               null;
+
+            elsif Is_Aliased_View (A) then
+               if Is_Constr_Subt_For_U_Nominal (A_Typ) then
+                  Nominal_Subt := Base_Type (A_Typ);
+               else
+                  Nominal_Subt := A_Typ;
+               end if;
+
+               if Subtypes_Statically_Match (F_Typ, Nominal_Subt) then
+                  null;
+
+               --  In a generic body assume the worst for generic formals:
+               --  they can have a constrained partial view (AI05-041).
+
+               elsif Has_Discriminants (F_Typ)
+                 and then not Is_Constrained (F_Typ)
+                 and then not Has_Constrained_Partial_View (F_Typ)
+                 and then not Is_Generic_Type (F_Typ)
+               then
+                  null;
+
+               else
+                  Error_Msg_NE ("untagged actual does not match "
+                    & "aliased formal&", A, F);
+               end if;
+
+            else
+               Error_Msg_NE ("actual for aliased formal& must be "
+                 & "aliased object", A, F);
+            end if;
+
+            if Ekind (Nam) = E_Procedure then
+               null;
+
+            elsif Ekind (Etype (Nam)) = E_Anonymous_Access_Type then
+               if Nkind (Parent (N)) = N_Type_Conversion
+                 and then Type_Access_Level (Etype (Parent (N)))
+                   < Object_Access_Level (A)
+               then
+                  Error_Msg_N ("aliased actual has wrong accessibility", A);
+               end if;
+
+            elsif Nkind (Parent (N)) = N_Qualified_Expression
+              and then Nkind (Parent (Parent (N))) = N_Allocator
+              and then Type_Access_Level (Etype (Parent (Parent (N))))
+                < Object_Access_Level (A)
+            then
+               Error_Msg_N
+                 ("Aliased actual in allocator has wrong accessibility", A);
+            end if;
+         end if;
+      end Check_Aliased_Parameter;
+
       --------------------------
       -- Check_Argument_Order --
       --------------------------
@@ -4213,6 +4281,8 @@ package body Sem_Res is
                end if;
             end if;
 
+            Check_Aliased_Parameter;
+
             Eval_Actual (A);
 
             --  If it is a named association, treat the selector_name as a
@@ -4426,6 +4496,7 @@ package body Sem_Res is
          end if;
 
          Resolve (Expression (E), Etype (E));
+         Check_Non_Static_Context (Expression (E));
          Check_Unset_Reference (Expression (E));
 
          --  A qualified expression requires an exact match of the type.
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 62a5bdb..c1d7581 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -7337,6 +7337,18 @@ package body Sem_Util is
                                   N_Package_Specification);
    end Has_Declarations;
 
+   ---------------------------------
+   -- Has_Defaulted_Discriminants --
+   ---------------------------------
+
+   function Has_Defaulted_Discriminants (Typ : Entity_Id) return Boolean is
+   begin
+      return Has_Discriminants (Typ)
+       and then Present (First_Discriminant (Typ))
+       and then Present
+         (Discriminant_Default_Value (First_Discriminant (Typ)));
+   end Has_Defaulted_Discriminants;
+
    -------------------
    -- Has_Denormals --
    -------------------
@@ -14414,7 +14426,15 @@ package body Sem_Util is
             return Type_Access_Level (Scope (E)) + 1;
 
          else
-            return Scope_Depth (Enclosing_Dynamic_Scope (E));
+            --  Aliased formals take their access level from the point of call.
+            --  This is smaller than the level of the subprogram itself.
+
+            if Is_Formal (E) and then Is_Aliased (E) then
+               return Type_Access_Level (Etype (E));
+
+            else
+               return Scope_Depth (Enclosing_Dynamic_Scope (E));
+            end if;
          end if;
 
       elsif Nkind (Obj) = N_Selected_Component then
@@ -14586,6 +14606,12 @@ package body Sem_Util is
       elsif Nkind (Obj) = N_Qualified_Expression then
          return Object_Access_Level (Expression (Obj));
 
+      --  Ditto for aggregates. They have the level of the temporary that
+      --  will hold their value.
+
+      elsif Nkind (Obj) = N_Aggregate then
+         return Object_Access_Level (Current_Scope);
+
       --  Otherwise return the scope level of Standard. (If there are cases
       --  that fall through to this point they will be treated as having
       --  global accessibility for now. ???)
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index 8140f61..6a0e126 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -884,6 +884,9 @@ package Sem_Util is
    --  as an access type internally, this function tests only for access types
    --  known to the programmer. See also Has_Tagged_Component.
 
+      function Has_Defaulted_Discriminants (Typ : Entity_Id) return Boolean;
+      --  Simple predicate to test for defaulted discriminants
+
    type Alignment_Result is (Known_Compatible, Unknown, Known_Incompatible);
    --  Result of Has_Compatible_Alignment test, description found below. Note
    --  that the values are arranged in increasing order of problematicness.