sem_ch13.adb, [...]: Minor reformatting.

2010-09-09  Robert Dewar  <dewar@adacore.com>

	* sem_ch13.adb, sem_ch6.adb, exp_ch3.adb: Minor reformatting.

2010-09-09  Robert Dewar  <dewar@adacore.com>

	* einfo.adb (Is_Aggregate_Type): New function.
	* einfo.ads (Aggregate_Kind): New enumeration subtype
	(Is_Aggregate_Type): New function.
	* sem_type.adb (Is_Array_Class_Record_Type): Removed, replaced by
	Is_Aggregate_Typea.

2010-09-09  Robert Dewar  <dewar@adacore.com>

	* exp_ch11.adb, frontend.adb, sem_attr.adb, sem_ch10.adb, sem_ch3.adb,
	sem_ch4.adb, sem_ch9.adb, sem_res.adb: Use Restriction_Check_Needed
	where appropriate.
	* restrict.ads, restrict.adb: Ditto.
	(Restriction_Check_Needed): New function

From-SVN: r164061

gcc/ada/ChangeLog

@@ -1,3 +1,23 @@
+2010-09-09  Robert Dewar  <dewar@adacore.com>
+
+	* sem_ch13.adb, sem_ch6.adb, exp_ch3.adb: Minor reformatting.
+
+2010-09-09  Robert Dewar  <dewar@adacore.com>
+
+	* einfo.adb (Is_Aggregate_Type): New function.
+	* einfo.ads (Aggregate_Kind): New enumeration subtype
+	(Is_Aggregate_Type): New function.
+	* sem_type.adb (Is_Array_Class_Record_Type): Removed, replaced by
+	Is_Aggregate_Typea.
+
+2010-09-09  Robert Dewar  <dewar@adacore.com>
+
+	* exp_ch11.adb, frontend.adb, sem_attr.adb, sem_ch10.adb, sem_ch3.adb,
+	sem_ch4.adb, sem_ch9.adb, sem_res.adb: Use Restriction_Check_Needed
+	where appropriate.
+	* restrict.ads, restrict.adb: Ditto.
+	(Restriction_Check_Needed): New function
+
 2010-09-09  Ed Schonberg  <schonberg@adacore.com>
 
 	* exp_ch9.ads (Find_Master_Scope): New function, extracted from

gcc/ada/einfo.adb

@@ -2731,6 +2731,11 @@ package body Einfo is
       return Ekind (Id) in Access_Subprogram_Kind;
    end Is_Access_Subprogram_Type;
 
+   function Is_Aggregate_Type                   (Id : E) return B is
+   begin
+      return Ekind (Id) in Aggregate_Kind;
+   end Is_Aggregate_Type;
+
    function Is_Array_Type                       (Id : E) return B is
    begin
       return Ekind (Id) in Array_Kind;

gcc/ada/einfo.ads

@@ -4209,6 +4209,17 @@ package Einfo is
       E_Access_Protected_Subprogram_Type ..
       E_Anonymous_Access_Protected_Subprogram_Type;
 
+   subtype Aggregate_Kind              is Entity_Kind range
+       E_Array_Type ..
+   --  E_Array_Subtype
+   --  E_String_Type
+   --  E_String_Subtype
+   --  E_String_Literal_Subtype
+   --  E_Class_Wide_Type
+   --  E_Class_Wide_Subtype
+   --  E_Record_Type
+       E_Record_Subtype;
+
    subtype Array_Kind                  is Entity_Kind range
        E_Array_Type ..
    --  E_Array_Subtype
@@ -6115,6 +6126,7 @@ package Einfo is
    function Is_Access_Type                      (Id : E) return B;
    function Is_Access_Protected_Subprogram_Type (Id : E) return B;
    function Is_Access_Subprogram_Type           (Id : E) return B;
+   function Is_Aggregate_Type                   (Id : E) return B;
    function Is_Array_Type                       (Id : E) return B;
    function Is_Assignable                       (Id : E) return B;
    function Is_Class_Wide_Type                  (Id : E) return B;
@@ -7125,6 +7137,7 @@ package Einfo is
    pragma Inline (Is_Access_Type);
    pragma Inline (Is_Access_Protected_Subprogram_Type);
    pragma Inline (Is_Access_Subprogram_Type);
+   pragma Inline (Is_Aggregate_Type);
    pragma Inline (Is_Aliased);
    pragma Inline (Is_Array_Type);
    pragma Inline (Is_Assignable);

gcc/ada/exp_ch11.adb

@@ -2006,7 +2006,7 @@ package body Exp_Ch11 is
 
    procedure Warn_If_No_Propagation (N : Node_Id) is
    begin
-      if Restriction_Active (No_Exception_Propagation)
+      if Restriction_Check_Required (No_Exception_Propagation)
         and then Warn_On_Non_Local_Exception
       then
          Warn_No_Exception_Propagation_Active (N);

gcc/ada/exp_ch3.adb

@@ -142,9 +142,9 @@ package body Exp_Ch3 is
    --  are active) can lead to very large blocks that GCC3 handles poorly.
 
    procedure Build_Untagged_Equality (Typ : Entity_Id);
-   --  AI05-0123: equality on untagged records composes. This procedure
+   --  AI05-0123: Equality on untagged records composes. This procedure
-   --  build the equality routine for an untagged record that has components
+   --  builds the equality routine for an untagged record that has components
-   --  of a record type that have user-defined primitive equality operations.
+   --  of a record type that has user-defined primitive equality operations.
    --  The resulting operation is a TSS subprogram.
 
    procedure Build_Variant_Record_Equality (Typ  : Entity_Id);
@@ -3766,9 +3766,9 @@ package body Exp_Ch3 is
       Eq_Op    : Entity_Id;
 
       function User_Defined_Eq (T : Entity_Id) return Entity_Id;
-      --  Check whether the type T has a user-defined primitive
+      --  Check whether the type T has a user-defined primitive equality. If so
-      --  equality. If true for a component of Typ, we have to
+      --  return it, else return Empty. If true for a component of Typ, we have
-      --  build the primitive equality for it.
+      --  to build the primitive equality for it.
 
       ---------------------
       -- User_Defined_Eq --
@@ -3807,7 +3807,7 @@ package body Exp_Ch3 is
 
    begin
       --  If a record component has a primitive equality operation, we must
-      --  builde the corresponding one for the current type.
+      --  build the corresponding one for the current type.
 
       Build_Eq := False;
       Comp := First_Component (Typ);
@@ -3828,7 +3828,11 @@ package body Exp_Ch3 is
       Eq_Op := Empty;
       while Present (Prim) loop
          if Chars (Node (Prim)) = Name_Op_Eq
-           and then Comes_From_Source (Node (Prim))
+              and then Comes_From_Source (Node (Prim))
+
+         --  Don't we also need to check formal types and return type as in
+         --  User_Defined_Eq above???
+
          then
             Eq_Op := Node (Prim);
             Build_Eq := False;
@@ -3839,10 +3843,10 @@ package body Exp_Ch3 is
       end loop;
 
       --  If the type is derived, inherit the operation, if present, from the
-      --  parent type. It may have been declared after the type derivation.
+      --  parent type. It may have been declared after the type derivation. If
-      --  If the parent type itself is derived, it may have inherited an
+      --  the parent type itself is derived, it may have inherited an operation
-      --  operation that has itself been overridden, so update its alias
+      --  that has itself been overridden, so update its alias and related
-      --  and related flags. Ditto for inequality.
+      --  flags. Ditto for inequality.
 
       if No (Eq_Op) and then Is_Derived_Type (Typ) then
          Prim := First_Elmt (Collect_Primitive_Operations (Etype (Typ)));
@@ -3877,13 +3881,12 @@ package body Exp_Ch3 is
          end loop;
       end if;
 
-      --  If not inherited and not user-defined, build body as for a type
+      --  If not inherited and not user-defined, build body as for a type with
-      --  with tagged components.
+      --  tagged components.
 
       if Build_Eq then
          Decl :=
-           Make_Eq_Body
+           Make_Eq_Body (Typ, Make_TSS_Name (Typ, TSS_Composite_Equality));
-             (Typ, Make_TSS_Name (Typ, TSS_Composite_Equality));
          Op := Defining_Entity (Decl);
          Set_TSS (Typ, Op);
          Set_Is_Pure (Op);
@@ -7824,8 +7827,8 @@ package body Exp_Ch3 is
             Comps := Component_List (Typ_Def);
          end if;
 
-         Variant_Case := Present (Comps)
+         Variant_Case :=
-           and then Present (Variant_Part (Comps));
+           Present (Comps) and then Present (Variant_Part (Comps));
       end if;
 
       if Variant_Case then

gcc/ada/frontend.adb

@@ -290,7 +290,7 @@ begin
    --  explicit switch turning off Warn_On_Non_Local_Exception, then turn on
    --  this warning by default if we have encountered an exception handler.
 
-   if Restriction_Active (No_Exception_Propagation)
+   if Restriction_Check_Required (No_Exception_Propagation)
      and then not No_Warn_On_Non_Local_Exception
      and then Exception_Handler_Encountered
    then

gcc/ada/restrict.adb

@@ -144,8 +144,8 @@ package body Restrict is
    --  Start of processing for Check_Obsolescent_2005_Entity
 
    begin
-      if Ada_Version >= Ada_2005
+      if Restriction_Check_Required (No_Obsolescent_Features)
-        and then Restriction_Active (No_Obsolescent_Features)
+        and then Ada_Version >= Ada_2005
         and then Chars_Is (Scope (E),                 "handling")
         and then Chars_Is (Scope (Scope (E)),         "characters")
         and then Chars_Is (Scope (Scope (Scope (E))), "ada")
@@ -298,8 +298,8 @@ package body Restrict is
    --  Start of processing for Check_Restriction
 
    begin
-      --  In CodePeer mode, we do not want to check for any restriction, or
+      --  In CodePeer mode, we do not want to check for any restriction, or set
-      --  set additional restrictions than those already set in gnat1drv.adb
+      --  additional restrictions other than those already set in gnat1drv.adb
       --  so that we have consistency between each compilation.
 
       if CodePeer_Mode then
@@ -403,7 +403,7 @@ package body Restrict is
 
    procedure Check_Wide_Character_Restriction (E : Entity_Id; N : Node_Id) is
    begin
-      if Restriction_Active (No_Wide_Characters)
+      if Restriction_Check_Required (No_Wide_Characters)
         and then Comes_From_Source (N)
       then
          declare
@@ -586,6 +586,15 @@ package body Restrict is
       return Restrictions.Set (R) and then not Restriction_Warnings (R);
    end Restriction_Active;
 
+   --------------------------------
+   -- Restriction_Check_Required --
+   --------------------------------
+
+   function Restriction_Check_Required (R : All_Restrictions) return Boolean is
+   begin
+      return Restrictions.Set (R);
+   end Restriction_Check_Required;
+
    ---------------------
    -- Restriction_Msg --
    ---------------------

gcc/ada/restrict.ads

@@ -292,7 +292,19 @@ package Restrict is
    --  used where the compiled code depends on whether the restriction is
    --  active. Always use Check_Restriction to record a violation. Note that
    --  this returns False if we only have a Restriction_Warnings set, since
-   --  restriction warnings should never affect generated code.
+   --  restriction warnings should never affect generated code. If you want
+   --  to know if a call to Check_Restriction is needed then use the function
+   --  Restriction_Check_Required instead.
+
+   function Restriction_Check_Required (R : All_Restrictions) return Boolean;
+   pragma Inline (Restriction_Check_Required);
+   --  Determines if either a Restriction_Warnings or Restrictions pragma has
+   --  been given for the specified restriction. If true, then a subsequent
+   --  call to Check_Restriction is required if the restriction is violated.
+   --  This must not be used to guard code generation that depends on whether
+   --  a restriction is active (see Restriction_Active above). Typically it
+   --  is used to avoid complex code to determine if a restriction is violated,
+   --  executing this code only if needed.
 
    function Restricted_Profile return Boolean;
    --  Tests if set of restrictions corresponding to Profile (Restricted) is

gcc/ada/sem_attr.adb

@@ -2549,7 +2549,7 @@ package body Sem_Attr is
          --  2005. Note that we can't test Is_Tagged_Type here on P_Type, since
          --  this flag gets set by Find_Type in this situation.
 
-         if Restriction_Active (No_Obsolescent_Features)
+         if Restriction_Check_Required (No_Obsolescent_Features)
            and then Ada_Version >= Ada_2005
            and then Ekind (P_Type) = E_Incomplete_Type
          then

gcc/ada/sem_ch10.adb

@@ -2325,7 +2325,7 @@ package body Sem_Ch10 is
       --  Note: this is not quite right if the user defines one of these units
       --  himself, but that's a marginal case, and fixing it is hard ???
 
-      if Restriction_Active (No_Obsolescent_Features) then
+      if Restriction_Check_Required (No_Obsolescent_Features) then
          declare
             F : constant File_Name_Type :=
                   Unit_File_Name (Get_Source_Unit (U));

gcc/ada/sem_ch13.adb

@@ -2360,8 +2360,8 @@ package body Sem_Ch13 is
       function Make_Null_Procedure_Specs (Tag_Typ : Entity_Id) return List_Id;
       --  Ada 2005 (AI-251): Makes specs for null procedures associated with
       --  null procedures inherited from interface types that have not been
-      --  overridden. Only one null procedure will be created for a given
+      --  overridden. Only one null procedure will be created for a given set
-      --  set of inherited null procedures with homographic profiles.
+      --  of inherited null procedures with homographic profiles.
 
       -------------------------------
       -- Make_Null_Procedure_Specs --
@@ -2419,8 +2419,8 @@ package body Sem_Ch13 is
                      --  of the interface type)
 
                      if Is_Controlling_Formal (Formal) then
-                        if Nkind (Parameter_Type (Parent (Formal)))
+                        if Nkind (Parameter_Type (Parent (Formal))) =
-                          = N_Identifier
+                                                              N_Identifier
                         then
                            Set_Parameter_Type (New_Param_Spec,
                              New_Occurrence_Of (Tag_Typ, Loc));

gcc/ada/sem_ch3.adb

@@ -2779,7 +2779,7 @@ package body Sem_Ch3 is
       --  Has_Stream just for efficiency reasons. There is no point in
       --  spending time on a Has_Stream check if the restriction is not set.
 
-      if Restrictions.Set (No_Streams) then
+      if Restriction_Check_Required (No_Streams) then
          if Has_Stream (T) then
             Check_Restriction (No_Streams, N);
          end if;
@@ -13659,7 +13659,7 @@ package body Sem_Ch3 is
 
             --  Check violation of No_Wide_Characters
 
-            if Restriction_Active (No_Wide_Characters) then
+            if Restriction_Check_Required (No_Wide_Characters) then
                Get_Name_String (Chars (L));
 
                if Name_Len >= 3 and then Name_Buffer (1 .. 2) = "QW" then

gcc/ada/sem_ch4.adb

@@ -617,7 +617,7 @@ package body Sem_Ch4 is
       --  Has_Stream just for efficiency reasons. There is no point in
       --  spending time on a Has_Stream check if the restriction is not set.
 
-      if Restrictions.Set (No_Streams) then
+      if Restriction_Check_Required (No_Streams) then
          if Has_Stream (Designated_Type (Acc_Type)) then
             Check_Restriction (No_Streams, N);
          end if;

gcc/ada/sem_ch6.adb

@@ -4037,9 +4037,7 @@ package body Sem_Ch6 is
                   Error_Msg_Name_2 := Get_Convention_Name (Convention (Op));
                   Error_Msg_Sloc   := Sloc (Op);
 
-                  if Comes_From_Source (Op)
+                  if Comes_From_Source (Op) or else No (Alias (Op)) then
-                    or else No (Alias (Op))
-                  then
                      if not Is_Overriding_Operation (Op) then
                         Error_Msg_N ("\\primitive % defined #", Typ);
                      else

gcc/ada/sem_ch9.adb

@@ -1182,9 +1182,9 @@ package body Sem_Ch9 is
       --  and the No_Local_Protected_Objects restriction applies, issue a
       --  warning that objects of the type will violate the restriction.
 
-      if not Is_Library_Level_Entity (T)
+      if Restriction_Check_Required (No_Local_Protected_Objects)
+        and then not Is_Library_Level_Entity (T)
         and then Comes_From_Source (T)
-        and then Restrictions.Set (No_Local_Protected_Objects)
       then
          Error_Msg_Sloc := Restrictions_Loc (No_Local_Protected_Objects);
 
@@ -1995,9 +1995,9 @@ package body Sem_Ch9 is
       --  No_Task_Hierarchy restriction applies, issue a warning that objects
       --  of the type will violate the restriction.
 
-      if not Is_Library_Level_Entity (T)
+      if Restriction_Check_Required (No_Task_Hierarchy)
+        and then not Is_Library_Level_Entity (T)
         and then Comes_From_Source (T)
-        and then Restrictions.Set (No_Task_Hierarchy)
       then
          Error_Msg_Sloc := Restrictions_Loc (No_Task_Hierarchy);
 
@@ -2193,18 +2193,10 @@ package body Sem_Ch9 is
                   --  Entry family with non-static bounds
 
                   else
-                     --  If restriction is set, then this is an error
+                     --  Record an unknown count restriction, and if the
+                     --  restriction is active, post a message or warning.
 
-                     if Restrictions.Set (R) then
+                     Check_Restriction (R, D);
-                        Error_Msg_N
-                          ("static subtype required by Restriction pragma",
-                           DSD);
-
-                     --  Otherwise we record an unknown count restriction
-
-                     else
-                        Check_Restriction (R, D);
-                     end if;
                   end if;
                end;
             end if;

gcc/ada/sem_res.adb

@@ -4759,7 +4759,7 @@ package body Sem_Res is
          --  violated if either operand can be negative for mod, or for rem
          --  if both operands can be negative.
 
-         if Restrictions.Set (No_Implicit_Conditionals)
+         if Restriction_Check_Required (No_Implicit_Conditionals)
            and then Nkind_In (N, N_Op_Rem, N_Op_Mod)
          then
             declare

gcc/ada/sem_type.adb

@@ -184,18 +184,6 @@ package body Sem_Type is
    --  Interp_Has_Abstract_Op. Determine whether an overloaded node has an
    --  abstract interpretation which yields type Typ.
 
-   function Is_Array_Class_Record_Type (E : Entity_Id) return Boolean;
-   --  This function tests if entity E is in Array_Kind, or Class_Wide_Kind,
-   --  or is E_Record_Type or E_Record_Subtype, and returns True for these
-   --  cases, and False for all others. Note that other record entity kinds
-   --  such as E_Record_Type_With_Private return False.
-   --
-   --  This is a bit of an odd category, maybe it is wrong or a better name
-   --  could be found for the class of entities being tested. The history
-   --  is that this used to be done with an explicit range test for the range
-   --  E_Array_Type .. E_Record_Subtype, which was itself suspicious and is
-   --  now prohibited by the -gnatyE style check ???
-
    procedure New_Interps (N : Node_Id);
    --  Initialize collection of interpretations for the given node, which is
    --  either an overloaded entity, or an operation whose arguments have
@@ -912,7 +900,7 @@ package body Sem_Type is
       --  An aggregate is compatible with an array or record type
 
       elsif T2 = Any_Composite
-        and then Is_Array_Class_Record_Type (T1)
+        and then Is_Aggregate_Type (T1)
       then
          return True;
 
@@ -2632,6 +2620,9 @@ package body Sem_Type is
                else
                   Par := Etype (Par);
                end if;
+
+            --  For all other cases return False, not an Ancestor
+
             else
                return False;
             end if;
@@ -2639,18 +2630,6 @@ package body Sem_Type is
       end if;
    end Is_Ancestor;
 
-   --------------------------------
-   -- Is_Array_Class_Record_Type --
-   --------------------------------
-
-   function Is_Array_Class_Record_Type (E : Entity_Id) return Boolean is
-   begin
-      return Is_Array_Type (E)
-        or else Is_Class_Wide_Type (E)
-        or else Ekind (E) = E_Record_Type
-        or else Ekind (E) = E_Record_Subtype;
-   end Is_Array_Class_Record_Type;
-
    ---------------------------
    -- Is_Invisible_Operator --
    ---------------------------
@@ -3069,12 +3048,12 @@ package body Sem_Type is
          return T1;
 
       elsif T2 = Any_Composite
-        and then Is_Array_Class_Record_Type (T1)
+        and then Is_Aggregate_Type (T1)
       then
          return T1;
 
       elsif T1 = Any_Composite
-        and then Is_Array_Class_Record_Type (T2)
+        and then Is_Aggregate_Type (T2)
       then
          return T2;