sem_aux.adb [...] (Effectively_has_Constrained_Partial_View): Rename subprogram…

sem_aux.adb [...] (Effectively_has_Constrained_Partial_View): Rename subprogram as Object_Type_Has_Constrained_Partial_View...

2013-04-23  Ed Schonberg  <schonberg@adacore.com>

	* sem_aux.adb sem_aux.ads (Effectively_has_Constrained_Partial_View):
	Rename subprogram as Object_Type_Has_Constrained_Partial_View, better
	description of purpose.
	* checks.adb (Apply_Discriminant_Check): Use above renaming.
	* sem_ch4.adb (Analyze_Allocator): Check Has_Constrained_Partial_View
	of the base type, rather than using the Object_Type predicate.
	* sem_attr.adb (Analyze_Attribute, case 'Access): Use above renaming.
	* sem_util.adb (Is_Dependent_Component_Of_Mutable_Object): ditto.
	* exp_attr.adb (Expand_N_Attribute_Reference, case 'Constrained): Ditto.
	* exp_ch4.adb (Expand_N_Allocator): Ditto.

From-SVN: r198188

gcc/ada/ChangeLog

+2013-04-23  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_aux.adb sem_aux.ads (Effectively_has_Constrained_Partial_View):
+	Rename subprogram as Object_Type_Has_Constrained_Partial_View, better
+	description of purpose.
+	* checks.adb (Apply_Discriminant_Check): Use above renaming.
+	* sem_ch4.adb (Analyze_Allocator): Check Has_Constrained_Partial_View
+	of the base type, rather than using the Object_Type predicate.
+	* sem_attr.adb (Analyze_Attribute, case 'Access): Use above renaming.
+	* sem_util.adb (Is_Dependent_Component_Of_Mutable_Object): ditto.
+	* exp_attr.adb (Expand_N_Attribute_Reference, case 'Constrained): Ditto.
+	* exp_ch4.adb (Expand_N_Allocator): Ditto.
+
 2013-04-23  Robert Dewar  <dewar@adacore.com>
 
 	* exp_prag.adb (Expand_Pragma_Check): Check for Assert rather

gcc/ada/checks.adb

@@ -1479,7 +1479,7 @@ package body Checks is
       --  partial view that is constrained.
 
       elsif Ada_Version >= Ada_2005
-        and then Effectively_Has_Constrained_Partial_View
+        and then Object_Type_Has_Constrained_Partial_View
                    (Typ  => Base_Type (T_Typ),
                     Scop => Current_Scope)
       then

gcc/ada/exp_attr.adb

@@ -1791,7 +1791,7 @@ package body Exp_Attr is
                          or else
                            (Nkind (Obj) = N_Explicit_Dereference
                               and then
-                                not Effectively_Has_Constrained_Partial_View
+                                not Object_Type_Has_Constrained_Partial_View
                                       (Typ  => Base_Type (Etype (Obj)),
                                        Scop => Current_Scope)));
             end if;
@@ -1915,7 +1915,7 @@ package body Exp_Attr is
                     or else
                      (Nkind (Pref) = N_Explicit_Dereference
                        and then
-                         not Effectively_Has_Constrained_Partial_View
+                         not Object_Type_Has_Constrained_Partial_View
                                (Typ  => Base_Type (Ptyp),
                                 Scop => Current_Scope))
                     or else Is_Constrained (Underlying_Type (Ptyp))

gcc/ada/exp_ch4.adb

@@ -4673,9 +4673,8 @@ package body Exp_Ch4 is
                                           (First_Discriminant (Typ)))
                        and then (Ada_Version < Ada_2005
                                   or else not
-                                    Effectively_Has_Constrained_Partial_View
-                                      (Typ  => Typ,
-                                       Scop => Current_Scope))
+                                    Object_Type_Has_Constrained_Partial_View
+                                      (Typ, Current_Scope))
                      then
                         Typ := Build_Default_Subtype (Typ, N);
                         Set_Expression (N, New_Reference_To (Typ, Loc));

gcc/ada/sem_attr.adb

@@ -9530,7 +9530,7 @@ package body Sem_Attr is
                  and then
                    (Ada_Version < Ada_2005
                      or else
-                       not Effectively_Has_Constrained_Partial_View
+                       not Object_Type_Has_Constrained_Partial_View
                              (Typ => Designated_Type (Base_Type (Typ)),
                               Scop => Current_Scope))
                then

gcc/ada/sem_aux.adb

@@ -151,25 +151,6 @@ package body Sem_Aux is
       end if;
    end Constant_Value;
 
-   ----------------------------------------------
-   -- Effectively_Has_Constrained_Partial_View --
-   ----------------------------------------------
-
-   function Effectively_Has_Constrained_Partial_View
-     (Typ  : Entity_Id;
-      Scop : Entity_Id) return Boolean
-   is
-   begin
-      return Has_Constrained_Partial_View (Typ)
-        or else (In_Generic_Body (Scop)
-                   and then Is_Generic_Type (Base_Type (Typ))
-                   and then Is_Private_Type (Base_Type (Typ))
-                   and then not Is_Tagged_Type (Typ)
-                   and then not (Is_Array_Type (Typ)
-                                   and then not Is_Constrained (Typ))
-                   and then Has_Discriminants (Typ));
-   end Effectively_Has_Constrained_Partial_View;
-
    -----------------------------
    -- Enclosing_Dynamic_Scope --
    -----------------------------
@@ -630,25 +611,6 @@ package body Sem_Aux is
       return Present (Get_Rep_Pragma (E, Nam1, Nam2, Check_Parents));
    end Has_Rep_Pragma;
 
-   -------------------------------
-   -- Initialization_Suppressed --
-   -------------------------------
-
-   function Initialization_Suppressed (Typ : Entity_Id) return Boolean is
-   begin
-      return Suppress_Initialization (Typ)
-        or else Suppress_Initialization (Base_Type (Typ));
-   end Initialization_Suppressed;
-
-   ----------------
-   -- Initialize --
-   ----------------
-
-   procedure Initialize is
-   begin
-      Obsolescent_Warnings.Init;
-   end Initialize;
-
    ---------------------
    -- In_Generic_Body --
    ---------------------
@@ -686,6 +648,25 @@ package body Sem_Aux is
       return False;
    end In_Generic_Body;
 
+   -------------------------------
+   -- Initialization_Suppressed --
+   -------------------------------
+
+   function Initialization_Suppressed (Typ : Entity_Id) return Boolean is
+   begin
+      return Suppress_Initialization (Typ)
+        or else Suppress_Initialization (Base_Type (Typ));
+   end Initialization_Suppressed;
+
+   ----------------
+   -- Initialize --
+   ----------------
+
+   procedure Initialize is
+   begin
+      Obsolescent_Warnings.Init;
+   end Initialize;
+
    ---------------------
    -- Is_By_Copy_Type --
    ---------------------
@@ -828,38 +809,6 @@ package body Sem_Aux is
       end if;
    end Is_Generic_Formal;
 
-   ---------------------------
-   -- Is_Indefinite_Subtype --
-   ---------------------------
-
-   function Is_Indefinite_Subtype (Ent : Entity_Id) return Boolean is
-      K : constant Entity_Kind := Ekind (Ent);
-
-   begin
-      if Is_Constrained (Ent) then
-         return False;
-
-      elsif K in Array_Kind
-        or else K in Class_Wide_Kind
-        or else Has_Unknown_Discriminants (Ent)
-      then
-         return True;
-
-      --  Known discriminants: indefinite if there are no default values
-
-      elsif K in Record_Kind
-        or else Is_Incomplete_Or_Private_Type (Ent)
-        or else Is_Concurrent_Type (Ent)
-      then
-         return (Has_Discriminants (Ent)
-           and then
-             No (Discriminant_Default_Value (First_Discriminant (Ent))));
-
-      else
-         return False;
-      end if;
-   end Is_Indefinite_Subtype;
-
    -------------------------------
    -- Is_Immutably_Limited_Type --
    -------------------------------
@@ -959,6 +908,38 @@ package body Sem_Aux is
       end if;
    end Is_Immutably_Limited_Type;
 
+   ---------------------------
+   -- Is_Indefinite_Subtype --
+   ---------------------------
+
+   function Is_Indefinite_Subtype (Ent : Entity_Id) return Boolean is
+      K : constant Entity_Kind := Ekind (Ent);
+
+   begin
+      if Is_Constrained (Ent) then
+         return False;
+
+      elsif K in Array_Kind
+        or else K in Class_Wide_Kind
+        or else Has_Unknown_Discriminants (Ent)
+      then
+         return True;
+
+      --  Known discriminants: indefinite if there are no default values
+
+      elsif K in Record_Kind
+        or else Is_Incomplete_Or_Private_Type (Ent)
+        or else Is_Concurrent_Type (Ent)
+      then
+         return (Has_Discriminants (Ent)
+           and then
+             No (Discriminant_Default_Value (First_Discriminant (Ent))));
+
+      else
+         return False;
+      end if;
+   end Is_Indefinite_Subtype;
+
    ---------------------
    -- Is_Limited_Type --
    ---------------------
@@ -1147,6 +1128,25 @@ package body Sem_Aux is
       return N;
    end Number_Discriminants;
 
+   ----------------------------------------------
+   -- Object_Type_Has_Constrained_Partial_View --
+   ----------------------------------------------
+
+   function Object_Type_Has_Constrained_Partial_View
+     (Typ  : Entity_Id;
+      Scop : Entity_Id) return Boolean
+   is
+   begin
+      return Has_Constrained_Partial_View (Typ)
+        or else (In_Generic_Body (Scop)
+                  and then Is_Generic_Type (Base_Type (Typ))
+                  and then Is_Private_Type (Base_Type (Typ))
+                  and then not Is_Tagged_Type (Typ)
+                  and then not (Is_Array_Type (Typ)
+                                 and then not Is_Constrained (Typ))
+                  and then Has_Discriminants (Typ));
+   end Object_Type_Has_Constrained_Partial_View;
+
    ---------------
    -- Tree_Read --
    ---------------

gcc/ada/sem_aux.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2012, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2013, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -105,14 +105,6 @@ package Sem_Aux is
    --  constants from the point of view of constant folding. Empty is also
    --  returned for variables with no initialization expression.
 
-   function Effectively_Has_Constrained_Partial_View
-     (Typ  : Entity_Id;
-      Scop : Entity_Id) return Boolean;
-   --  Return True if Typ has attribute Has_Constrained_Partial_View set to
-   --  True; in addition, within a generic body, return True if a subtype is
-   --  a descendant of an untagged generic formal private or derived type, and
-   --  the subtype is not an unconstrained array subtype (RM 3.3(23.10/3)).
-
    function Enclosing_Dynamic_Scope (Ent : Entity_Id) return Entity_Id;
    --  For any entity, Ent, returns the closest dynamic scope in which the
    --  entity is declared or Standard_Standard for library-level entities.
@@ -259,6 +251,12 @@ package Sem_Aux is
    function In_Generic_Body (Id : Entity_Id) return Boolean;
    --  Determine whether entity Id appears inside a generic body
 
+   function Initialization_Suppressed (Typ : Entity_Id) return Boolean;
+   pragma Inline (Initialization_Suppressed);
+   --  Returns True if initialization should be suppressed for the given type
+   --  or subtype. This is true if Suppress_Initialization is set either for
+   --  the subtype itself, or for the corresponding base type.
+
    function Is_By_Copy_Type (Ent : Entity_Id) return Boolean;
    --  Ent is any entity. Returns True if Ent is a type entity where the type
    --  is required to be passed by copy, as defined in (RM 6.2(3)).
@@ -329,11 +327,14 @@ package Sem_Aux is
    function Number_Discriminants (Typ : Entity_Id) return Pos;
    --  Typ is a type with discriminants, yields number of discriminants in type
 
-   function Initialization_Suppressed (Typ : Entity_Id) return Boolean;
-   pragma Inline (Initialization_Suppressed);
-   --  Returns True if initialization should be suppressed for the given type
-   --  or subtype. This is true if Suppress_Initialization is set either for
-   --  the subtype itself, or for the corresponding base type.
+   function Object_Type_Has_Constrained_Partial_View
+     (Typ  : Entity_Id;
+      Scop : Entity_Id) return Boolean;
+   --  Return True if type of object has attribute Has_Constrained_Partial_View
+   --  set to True; in addition, within a generic body, return True if subtype
+   --  of the object is a descendant of an untagged generic formal private or
+   --  derived type, and the subtype is not an unconstrained array subtype
+   --  (RM 3.3(23.10/3)).
 
    function Ultimate_Alias (Prim : Entity_Id) return Entity_Id;
    pragma Inline (Ultimate_Alias);

gcc/ada/sem_ch4.adb

@@ -580,9 +580,7 @@ package body Sem_Ch4 is
                --  and the allocated object is unconstrained.
 
                elsif Ada_Version >= Ada_2005
-                 and then Effectively_Has_Constrained_Partial_View
-                            (Typ  => Base_Typ,
-                             Scop => Current_Scope)
+                 and then Has_Constrained_Partial_View (Base_Typ)
                then
                   Error_Msg_N
                     ("constraint not allowed when type " &

gcc/ada/sem_util.adb

@@ -7980,7 +7980,7 @@ package body Sem_Util is
                   --  designated object is known to be constrained.
 
                   if Ekind (Prefix_Type) = E_Access_Type
-                    and then not Effectively_Has_Constrained_Partial_View
+                    and then not Object_Type_Has_Constrained_Partial_View
                                    (Typ  => Designated_Type (Prefix_Type),
                                     Scop => Current_Scope)
                   then