sem_aux.ads, [...] (Is_Immutably_Limited_Type): Make predicate compatible with Ada 2012 definition

2013-10-17  Ed Schonberg  <schonberg@adacore.com>

	* sem_aux.ads, sem_aux.adb (Is_Immutably_Limited_Type): Make
	predicate compatible with Ada 2012 definition
	(Is_Limited_View): New name for previous version of
	Is_Immutably_Limited_Type.  Predicate is true for an untagged
	record type with a limited component.
	* exp_ch7.adb, exp_ch6.adb, exp_ch4.adb, exp_ch3.adb, exp_aggr.adb,
	sem_util.adb, sem_res.adb, sem_prag.adb, sem_attr.adb, sem_ch8.adb,
	sem_ch6.adb, sem_ch3.adb, exp_util.adb: Use Is_Limited_View
	* freeze.adb Use Is_Immutably_Limited_Type to check the legality
	of references to the current instance, Is_Limited_View otherwise.

From-SVN: r203762

17 files changed, 117 insertions, 40 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 9f55cad..0580bf2 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,16 @@
+2013-10-17  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_aux.ads, sem_aux.adb (Is_Immutably_Limited_Type): Make
+	predicate compatible with Ada 2012 definition
+	(Is_Limited_View): New name for previous version of
+	Is_Immutably_Limited_Type.  Predicate is true for an untagged
+	record type with a limited component.
+	* exp_ch7.adb, exp_ch6.adb, exp_ch4.adb, exp_ch3.adb, exp_aggr.adb,
+	sem_util.adb, sem_res.adb, sem_prag.adb, sem_attr.adb, sem_ch8.adb,
+	sem_ch6.adb, sem_ch3.adb, exp_util.adb: Use Is_Limited_View
+	* freeze.adb Use Is_Immutably_Limited_Type to check the legality
+	of references to the current instance, Is_Limited_View otherwise.
+
 2013-10-17  Hristian Kirtchev  <kirtchev@adacore.com>
 
 	* sem_ch13.adb (Analyze_Aspect_Specifications): Flag aspect
diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index 9d72485..20a82b1 100644
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -628,7 +628,7 @@ package body Exp_Aggr is
       --  If component is limited, aggregate must be expanded because each
       --  component assignment must be built in place.
 
-      if Is_Immutably_Limited_Type (Component_Type (Typ)) then
+      if Is_Limited_View (Component_Type (Typ)) then
          return False;
       end if;
 
@@ -3347,7 +3347,7 @@ package body Exp_Aggr is
          --  in place within the caller's scope).
 
          or else
-           (Is_Immutably_Limited_Type (Typ)
+           (Is_Limited_View (Typ)
              and then
                (Nkind (Parent (Parent_Node)) = N_Extended_Return_Statement
                  or else Nkind (Parent_Node) = N_Simple_Return_Statement))
@@ -5668,7 +5668,7 @@ package body Exp_Aggr is
       --  Extension aggregates, aggregates in extended return statements, and
       --  aggregates for C++ imported types must be expanded.
 
-      if Ada_Version >= Ada_2005 and then Is_Immutably_Limited_Type (Typ) then
+      if Ada_Version >= Ada_2005 and then Is_Limited_View (Typ) then
          if not Nkind_In (Parent (N), N_Object_Declaration,
                                       N_Component_Association)
          then
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index e7d0cb0..f1ab0c5 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -1893,7 +1893,7 @@ package body Exp_Ch3 is
 
          if Needs_Finalization (Typ)
            and then not (Nkind_In (Kind, N_Aggregate, N_Extension_Aggregate))
-           and then not Is_Immutably_Limited_Type (Typ)
+           and then not Is_Limited_View (Typ)
          then
             Append_To (Res,
               Make_Adjust_Call
@@ -5310,7 +5310,7 @@ package body Exp_Ch3 is
             --  creating the object (via allocator) and initializing it.
 
             if Is_Return_Object (Def_Id)
-              and then Is_Immutably_Limited_Type (Typ)
+              and then Is_Limited_View (Typ)
             then
                null;
 
@@ -5578,7 +5578,7 @@ package body Exp_Ch3 is
             --  renaming declaration.
 
             if Needs_Finalization (Typ)
-              and then not Is_Immutably_Limited_Type (Typ)
+              and then not Is_Limited_View (Typ)
               and then not Rewrite_As_Renaming
             then
                Insert_Action_After (Init_After,
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 8df4576..00da147 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -1244,7 +1244,7 @@ package body Exp_Ch4 is
             --  want to Adjust.
 
             if not Aggr_In_Place
-              and then not Is_Immutably_Limited_Type (T)
+              and then not Is_Limited_View (T)
             then
                Insert_Action (N,
 
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 5421267..adc0987 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -3947,7 +3947,7 @@ package body Exp_Ch6 is
       --  result from the secondary stack.
 
       if Needs_Finalization (Etype (Subp)) then
-         if not Is_Immutably_Limited_Type (Etype (Subp))
+         if not Is_Limited_View (Etype (Subp))
            and then
              (No (First_Formal (Subp))
                 or else
@@ -7100,7 +7100,7 @@ package body Exp_Ch6 is
          then
             null;
 
-         elsif Is_Immutably_Limited_Type (Typ) then
+         elsif Is_Limited_View (Typ) then
             Set_Returns_By_Ref (Spec_Id);
 
          elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then
@@ -7702,7 +7702,7 @@ package body Exp_Ch6 is
       --  the type of the expression may be.
 
       if not Comes_From_Extended_Return_Statement (N)
-        and then Is_Immutably_Limited_Type (Etype (Expression (N)))
+        and then Is_Limited_View (Etype (Expression (N)))
         and then Ada_Version >= Ada_2005
         and then not Debug_Flag_Dot_L
 
@@ -7781,7 +7781,7 @@ package body Exp_Ch6 is
       --  type that requires special processing (indicated by the fact that
       --  it requires a cleanup scope for the secondary stack case).
 
-      if Is_Immutably_Limited_Type (Exptyp)
+      if Is_Limited_View (Exptyp)
         or else Is_Limited_Interface (Exptyp)
       then
          null;
@@ -9572,7 +9572,7 @@ package body Exp_Ch6 is
          --  may return objects of nonlimited descendants.
 
          else
-            return Is_Immutably_Limited_Type (Etype (E))
+            return Is_Limited_View (Etype (E))
               and then Ada_Version >= Ada_2005
               and then not Debug_Flag_Dot_L;
          end if;
@@ -9813,7 +9813,7 @@ package body Exp_Ch6 is
          Typ  : constant Entity_Id := Etype (Subp);
          Utyp : constant Entity_Id := Underlying_Type (Typ);
       begin
-         if Is_Immutably_Limited_Type (Typ) then
+         if Is_Limited_View (Typ) then
             Set_Returns_By_Ref (Subp);
          elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then
             Set_Returns_By_Ref (Subp);
diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index 9d76d2c..8449f6a 100644
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -432,7 +432,7 @@ package body Exp_Ch7 is
            Typ   => Typ,
            Stmts => Make_Deep_Array_Body (Initialize_Case, Typ)));
 
-      if not Is_Immutably_Limited_Type (Typ) then
+      if not Is_Limited_View (Typ) then
          Set_TSS (Typ,
            Make_Deep_Proc
              (Prim  => Adjust_Case,
@@ -3227,7 +3227,7 @@ package body Exp_Ch7 is
            Typ   => Typ,
            Stmts => Make_Deep_Record_Body (Initialize_Case, Typ)));
 
-      if not Is_Immutably_Limited_Type (Typ) then
+      if not Is_Limited_View (Typ) then
          Set_TSS (Typ,
            Make_Deep_Proc
              (Prim  => Adjust_Case,
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index 1d8df6b..2e0185e 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -2227,7 +2227,7 @@ package body Exp_Util is
       --  function being called is build-in-place. This will have to be revised
       --  when build-in-place functions are generalized to other types.
 
-      elsif Is_Immutably_Limited_Type (Exp_Typ)
+      elsif Is_Limited_View (Exp_Typ)
         and then
          (Is_Class_Wide_Type (Exp_Typ)
            or else Is_Interface (Exp_Typ)
@@ -7081,7 +7081,7 @@ package body Exp_Util is
 
          if Ada_Version >= Ada_2005
            and then Nkind (Exp) = N_Function_Call
-           and then Is_Immutably_Limited_Type (Etype (Exp))
+           and then Is_Limited_View (Etype (Exp))
            and then Nkind (Parent (Exp)) /= N_Object_Declaration
          then
             declare
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index f9691d7..a554ece 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -4786,7 +4786,7 @@ package body Freeze is
 
                if Has_Private_Declaration (E) then
                   if (not Is_Record_Type (E)
-                       or else not Is_Immutably_Limited_Type (E))
+                       or else not Is_Limited_View (E))
                     and then not Is_Private_Type (E)
                   then
                      Error_Msg_Name_1 := Name_Simple_Storage_Pool_Type;
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index 5234d47..231d0b2 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -3893,7 +3893,7 @@ package body Sem_Attr is
          --  Loop_Entry must create a constant initialized by the evaluated
          --  prefix.
 
-         if Is_Immutably_Limited_Type (Etype (P)) then
+         if Is_Limited_View (Etype (P)) then
             Error_Attr_P ("prefix of attribute % cannot be limited");
          end if;
 
@@ -5994,7 +5994,7 @@ package body Sem_Attr is
          then
             Error_Attr_P ("prefix of attribute % must be a record or array");
 
-         elsif Is_Immutably_Limited_Type (P_Type) then
+         elsif Is_Limited_View (P_Type) then
             Error_Attr ("prefix of attribute % cannot be limited", N);
 
          elsif Nkind (E1) /= N_Aggregate then
diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb
index 4e6fc1c..24470ed 100644
--- a/gcc/ada/sem_aux.adb
+++ b/gcc/ada/sem_aux.adb
@@ -813,11 +813,11 @@ package body Sem_Aux is
       end if;
    end Is_Generic_Formal;
 
-   -------------------------------
-   -- Is_Immutably_Limited_Type --
-   -------------------------------
+   ---------------------
+   -- Is_Limited_View --
+   ---------------------
 
-   function Is_Immutably_Limited_Type (Ent : Entity_Id) return Boolean is
+   function Is_Limited_View (Ent : Entity_Id) return Boolean is
       Btype : constant Entity_Id := Available_View (Base_Type (Ent));
 
    begin
@@ -857,7 +857,7 @@ package body Sem_Aux is
                if No (Utyp) then
                   return False;
                else
-                  return Is_Immutably_Limited_Type (Utyp);
+                  return Is_Limited_View (Utyp);
                end if;
             end;
          end if;
@@ -875,7 +875,7 @@ package body Sem_Aux is
          --  of a type that is not inherently limited.
 
          if Is_Class_Wide_Type (Btype) then
-            return Is_Immutably_Limited_Type (Root_Type (Btype));
+            return Is_Limited_View (Root_Type (Btype));
 
          else
             declare
@@ -892,7 +892,7 @@ package body Sem_Aux is
                   --  limited interfaces.
 
                   if not Is_Interface (Etype (C))
-                    and then Is_Immutably_Limited_Type (Etype (C))
+                    and then Is_Limited_View (Etype (C))
                   then
                      return True;
                   end if;
@@ -905,7 +905,64 @@ package body Sem_Aux is
          end if;
 
       elsif Is_Array_Type (Btype) then
-         return Is_Immutably_Limited_Type (Component_Type (Btype));
+         return Is_Limited_View (Component_Type (Btype));
+
+      else
+         return False;
+      end if;
+   end Is_Limited_View;
+
+   -------------------------------
+   -- Is_Immutably_Limited_Type --
+   -------------------------------
+
+   function Is_Immutably_Limited_Type (Ent : Entity_Id) return Boolean is
+      Btype : constant Entity_Id := Available_View (Base_Type (Ent));
+
+   begin
+      if Is_Limited_Record (Btype) then
+         return True;
+
+      elsif Ekind (Btype) = E_Limited_Private_Type
+        and then Nkind (Parent (Btype)) = N_Formal_Type_Declaration
+      then
+         return not In_Package_Body (Scope ((Btype)));
+
+      elsif Is_Private_Type (Btype) then
+
+         --  AI05-0063: A type derived from a limited private formal type is
+         --  not immutably limited in a generic body.
+
+         if Is_Derived_Type (Btype)
+           and then Is_Generic_Type (Etype (Btype))
+         then
+            if not Is_Limited_Type (Etype (Btype)) then
+               return False;
+
+            --  A descendant of a limited formal type is not immutably limited
+            --  in the generic body, or in the body of a generic child.
+
+            elsif Ekind (Scope (Etype (Btype))) = E_Generic_Package then
+               return not In_Package_Body (Scope (Btype));
+
+            else
+               return False;
+            end if;
+
+         else
+            declare
+               Utyp : constant Entity_Id := Underlying_Type (Btype);
+            begin
+               if No (Utyp) then
+                  return False;
+               else
+                  return Is_Immutably_Limited_Type (Utyp);
+               end if;
+            end;
+         end if;
+
+      elsif Is_Concurrent_Type (Btype) then
+         return True;
 
       else
          return False;
diff --git a/gcc/ada/sem_aux.ads b/gcc/ada/sem_aux.ads
index a4b1a67..0e2818e 100644
--- a/gcc/ada/sem_aux.ads
+++ b/gcc/ada/sem_aux.ads
@@ -281,6 +281,12 @@ package Sem_Aux is
    --  so. False for other type entities, or any entities that are not types.
 
    function Is_Immutably_Limited_Type (Ent : Entity_Id) return Boolean;
+   --  Implements definition in Ada 2012 RM-7.5 (8.1/3). This differs from the
+   --  following predicate in that an untagged record with immutably limited
+   --  components is NOT by itself immutably limited. This matters, eg. when
+   --  checking the legality of an access to the current instance.
+
+   function Is_Limited_View (Ent : Entity_Id) return Boolean;
    --  Ent is any entity. True for a type that is "inherently" limited (i.e.
    --  cannot become nonlimited). From the Ada 2005 RM-7.5(8.1/2), "a type with
    --  a part that is of a task, protected, or explicitly limited record type".
@@ -294,7 +300,8 @@ package Sem_Aux is
    --  Ent is any entity. Returns true if Ent is a limited type (limited
    --  private type, limited interface type, task type, protected type,
    --  composite containing a limited component, or a subtype of any of
-   --  these types).
+   --  these types). This older routine overlaps with the previous one, this
+   --  should be cleaned up?
 
    function Nearest_Ancestor (Typ : Entity_Id) return Entity_Id;
    --  Given a subtype Typ, this function finds out the nearest ancestor from
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 50ef808..3dffc053 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -9556,7 +9556,7 @@ package body Sem_Ch3 is
       --  or else be a partial view.
 
       if Nkind (Discriminant_Type (D)) = N_Access_Definition then
-         if Is_Immutably_Limited_Type (Current_Scope)
+         if Is_Limited_View (Current_Scope)
            or else
              (Nkind (Parent (Current_Scope)) = N_Private_Type_Declaration
                and then Limited_Present (Parent (Current_Scope)))
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 1ad5f2d..3b5eee1 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -586,7 +586,7 @@ package body Sem_Ch6 is
                  ("(Ada 2005) cannot copy object of a limited type " &
                   "(RM-2005 6.5(5.5/2))", Expr);
 
-               if Is_Immutably_Limited_Type (R_Type) then
+               if Is_Limited_View (R_Type) then
                   Error_Msg_N
                     ("\return by reference not permitted in Ada 2005", Expr);
                end if;
@@ -606,7 +606,7 @@ package body Sem_Ch6 is
                     ("return of limited object not permitted in Ada 2005 "
                      & "(RM-2005 6.5(5.5/2))?y?", Expr);
 
-               elsif Is_Immutably_Limited_Type (R_Type) then
+               elsif Is_Limited_View (R_Type) then
                   Error_Msg_N
                     ("return by reference not permitted in Ada 2005 "
                      & "(RM-2005 6.5(5.5/2))?y?", Expr);
@@ -880,7 +880,7 @@ package body Sem_Ch6 is
                     ("aliased only allowed for limited"
                      & " return objects in Ada 2012?", N);
 
-               elsif not Is_Immutably_Limited_Type (R_Type) then
+               elsif not Is_Limited_View (R_Type) then
                   Error_Msg_N ("aliased only allowed for limited"
                      & " return objects", N);
                end if;
@@ -963,7 +963,7 @@ package body Sem_Ch6 is
          --  check the static cases.
 
          if (Ada_Version < Ada_2005 or else Debug_Flag_Dot_L)
-           and then Is_Immutably_Limited_Type (Etype (Scope_Id))
+           and then Is_Limited_View (Etype (Scope_Id))
            and then Object_Access_Level (Expr) >
                       Subprogram_Access_Level (Scope_Id)
          then
@@ -6593,7 +6593,7 @@ package body Sem_Ch6 is
             Typ  : constant Entity_Id := Etype (Designator);
             Utyp : constant Entity_Id := Underlying_Type (Typ);
          begin
-            if Is_Immutably_Limited_Type (Typ) then
+            if Is_Limited_View (Typ) then
                Set_Returns_By_Ref (Designator);
             elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then
                Set_Returns_By_Ref (Designator);
diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb
index 34b5259..61d9766 100644
--- a/gcc/ada/sem_ch8.adb
+++ b/gcc/ada/sem_ch8.adb
@@ -883,7 +883,7 @@ package body Sem_Ch8 is
          --  there is no copy involved and no performance hit.
 
          if Nkind (Nam) = N_Function_Call
-           and then Is_Immutably_Limited_Type (Etype (Nam))
+           and then Is_Limited_View (Etype (Nam))
            and then not Is_Constrained (Etype (Nam))
            and then Comes_From_Source (N)
          then
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 1193a9c..62aa1b1 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -17678,7 +17678,7 @@ package body Sem_Prag is
             --  in Freeze_Entity).
 
             if Is_Record_Type (Typ)
-              and then not Is_Immutably_Limited_Type (Typ)
+              and then not Is_Limited_View (Typ)
             then
                Error_Pragma
                  ("pragma% can only apply to explicitly limited record type");
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 8b61012..805dc68 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -4356,7 +4356,7 @@ package body Sem_Res is
          --  of the current b-i-p implementation to unify the handling for
          --  multiple kinds of storage pools). ???
 
-         if Is_Immutably_Limited_Type (Desig_T)
+         if Is_Limited_View (Desig_T)
            and then Nkind (Expression (E)) = N_Function_Call
          then
             declare
@@ -4595,7 +4595,7 @@ package body Sem_Res is
 
                if Ada_Version >= Ada_2012
                  and then Is_Limited_Type (Desig_T)
-                 and then not Is_Immutably_Limited_Type (Scope (Discr))
+                 and then not Is_Limited_View (Scope (Discr))
                then
                   Error_Msg_N
                     ("only immutably limited types can have anonymous "
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index d2d8a41..f0dcd03 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -8145,7 +8145,7 @@ package body Sem_Util is
            --  statement is aliased if its type is immutably limited.
 
            or else (Is_Return_Object (E)
-                     and then Is_Immutably_Limited_Type (Etype (E)));
+                     and then Is_Limited_View (Etype (E)));
 
       elsif Nkind (Obj) = N_Selected_Component then
          return Is_Aliased (Entity (Selector_Name (Obj)));