[multiple changes]

2012-02-17  Robert Dewar  <dewar@adacore.com>

	* sem_dim.adb, sem_dim.ads, s-tasren.adb, prj.adb, prj.ads, freeze.adb,
	sem_res.adb, exp_ch4.adb, sinput.adb, sinput.ads, exp_aggr.adb,
	exp_intr.adb, s-os_lib.adb: Minor reformatting.

2012-02-17  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch6.adb (Is_Non_Overriding_Operation): Add warning if the
	old operation is abstract, the relevant type is not abstract,
	and the new subprogram fails to override.

From-SVN: r184336

gcc/ada/ChangeLog

@@ -1,3 +1,15 @@
+2012-02-17  Robert Dewar  <dewar@adacore.com>
+
+	* sem_dim.adb, sem_dim.ads, s-tasren.adb, prj.adb, prj.ads, freeze.adb,
+	sem_res.adb, exp_ch4.adb, sinput.adb, sinput.ads, exp_aggr.adb,
+	exp_intr.adb, s-os_lib.adb: Minor reformatting.
+
+2012-02-17  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_ch6.adb (Is_Non_Overriding_Operation): Add warning if the
+	old operation is abstract, the relevant type is not abstract,
+	and the new subprogram fails to override.
+
 2012-02-15  Eric Botcazou  <ebotcazou@adacore.com>
 
 	* gcc-interface/trans.c (Identifier_to_gnu): Move block retrieving the

gcc/ada/exp_aggr.adb

@@ -5157,9 +5157,9 @@ package body Exp_Aggr is
       -- Compile_Time_Known_Composite_Value --
       ----------------------------------------
 
-      function Compile_Time_Known_Composite_Value (N : Node_Id) return Boolean
+      function Compile_Time_Known_Composite_Value
+        (N : Node_Id) return Boolean
       is
-
       begin
          --  If we have an entity name, then see if it is the name of a
          --  constant and if so, test the corresponding constant value.
@@ -5168,15 +5168,14 @@ package body Exp_Aggr is
             declare
                E : constant Entity_Id := Entity (N);
                V : Node_Id;
-
             begin
                if Ekind (E) /= E_Constant then
                   return False;
+               else
+                  V := Constant_Value (E);
+                  return Present (V)
+                    and then Compile_Time_Known_Composite_Value (V);
                end if;
-
-               V := Constant_Value (E);
-               return Present (V)
-                 and then Compile_Time_Known_Composite_Value (V);
             end;
 
          --  We have a value, see if it is compile time known

gcc/ada/exp_ch4.adb

@@ -3572,21 +3572,20 @@ package body Exp_Ch4 is
                              (Etype (Pool), Name_Simple_Storage_Pool_Type))
             then
                declare
-                  Alloc_Op  : Entity_Id := Get_Name_Entity_Id (Name_Allocate);
                   Pool_Type : constant Entity_Id := Base_Type (Etype (Pool));
-
+                  Alloc_Op  : Entity_Id;
                begin
+                  Alloc_Op := Get_Name_Entity_Id (Name_Allocate);
                   while Present (Alloc_Op) loop
                      if Scope (Alloc_Op) = Scope (Pool_Type)
                        and then Present (First_Formal (Alloc_Op))
                        and then Etype (First_Formal (Alloc_Op)) = Pool_Type
                      then
                         Set_Procedure_To_Call (N, Alloc_Op);
-
                         exit;
+                     else
+                        Alloc_Op := Homonym (Alloc_Op);
                      end if;
-
-                     Alloc_Op := Homonym (Alloc_Op);
                   end loop;
                end;
 

gcc/ada/exp_intr.adb

@@ -1094,21 +1094,20 @@ package body Exp_Intr is
                           (Etype (Pool), Name_Simple_Storage_Pool_Type))
          then
             declare
-               Dealloc_Op  : Entity_Id := Get_Name_Entity_Id (Name_Deallocate);
+               Pool_Type  : constant Entity_Id := Base_Type (Etype (Pool));
-               Pool_Type : constant Entity_Id := Base_Type (Etype (Pool));
+               Dealloc_Op : Entity_Id;
-
             begin
+               Dealloc_Op := Get_Name_Entity_Id (Name_Deallocate);
                while Present (Dealloc_Op) loop
                   if Scope (Dealloc_Op) = Scope (Pool_Type)
                     and then Present (First_Formal (Dealloc_Op))
                     and then Etype (First_Formal (Dealloc_Op)) = Pool_Type
                   then
                      Set_Procedure_To_Call (Free_Node, Dealloc_Op);
-
                      exit;
+                  else
+                     Dealloc_Op := Homonym (Dealloc_Op);
                   end if;
-
-                  Dealloc_Op := Homonym (Dealloc_Op);
                end loop;
             end;
 
@@ -1140,8 +1139,8 @@ package body Exp_Intr is
          if Is_Class_Wide_Type (Desig_T)
            or else
             (Is_Array_Type (Desig_T)
-               and then not Is_Constrained (Desig_T)
+              and then not Is_Constrained (Desig_T)
-               and then Is_Packed (Desig_T))
+              and then Is_Packed (Desig_T))
          then
             declare
                Deref    : constant Node_Id :=

gcc/ada/freeze.adb

@@ -4114,7 +4114,6 @@ package body Freeze is
             if Present (Get_Rep_Pragma (E, Name_Simple_Storage_Pool_Type))
               and then (Is_Base_Type (E) or else Has_Private_Declaration (E))
             then
-
                --  If the type is marked Has_Private_Declaration, then this is
                --  a full type for a private type that was specified with the
                --  pragma Simple_Storage_Pool_Type, and here we ensure that the
@@ -4127,7 +4126,6 @@ package body Freeze is
                     and then not Is_Private_Type (E)
                   then
                      Error_Msg_Name_1 := Name_Simple_Storage_Pool_Type;
-
                      Error_Msg_N
                        ("pragma% can only apply to full type that is an " &
                         "explicitly limited type", E);
@@ -4197,6 +4195,7 @@ package body Freeze is
                      end if;
 
                      if Etype (Pool_Op_Formal) /= Expected_Type then
+
                         --  If the pool type was expected for this formal, then
                         --  this will not be considered a candidate operation
                         --  for the simple pool, so we unset OK_Formal so that
@@ -4243,8 +4242,8 @@ package body Freeze is
                   begin
                      pragma Assert
                        (Op_Name = Name_Allocate
-                          or else Op_Name = Name_Deallocate
+                         or else Op_Name = Name_Deallocate
-                          or else Op_Name = Name_Storage_Size);
+                         or else Op_Name = Name_Storage_Size);
 
                      Error_Msg_Name_1 := Op_Name;
 
@@ -4270,7 +4269,6 @@ package body Freeze is
                               Validate_Simple_Pool_Op_Formal
                                 (Op, Formal, E_In_Parameter, Pool_Type,
                                  "Pool", Is_OK);
-
                            else
                               Validate_Simple_Pool_Op_Formal
                                 (Op, Formal, E_In_Out_Parameter, Pool_Type,
@@ -4295,7 +4293,6 @@ package body Freeze is
                               Validate_Simple_Pool_Op_Formal
                                 (Op, Formal, E_Out_Parameter,
                                  Address_Type, "Storage_Address", Is_OK);
-
                            elsif Op_Name = Name_Deallocate then
                               Validate_Simple_Pool_Op_Formal
                                 (Op, Formal, E_In_Parameter,
@@ -4310,7 +4307,6 @@ package body Freeze is
                               Validate_Simple_Pool_Op_Formal
                                 (Op, Formal, E_In_Parameter,
                                  Stg_Cnt_Type, "Size_In_Storage_Units", Is_OK);
-
                               Validate_Simple_Pool_Op_Formal
                                 (Op, Formal, E_In_Parameter,
                                  Stg_Cnt_Type, "Alignment", Is_OK);
@@ -4338,6 +4334,7 @@ package body Freeze is
                                      "storage pool type", Pool_Type);
 
                      elsif Present (Found_Op) then
+
                         --  Simple pool operations can't be abstract
 
                         if Is_Abstract_Subprogram (Found_Op) then
@@ -4373,9 +4370,7 @@ package body Freeze is
 
                begin
                   Validate_Simple_Pool_Operation (Name_Allocate);
-
                   Validate_Simple_Pool_Operation (Name_Deallocate);
-
                   Validate_Simple_Pool_Operation (Name_Storage_Size);
                end Validate_Simple_Pool_Ops;
             end if;

gcc/ada/prj.adb

@@ -1893,6 +1893,7 @@ package body Prj is
       is
          Agg : Aggregated_Project_List;
          Ctx : Project_Context;
+
       begin
          Action (Project, Tree, Context);
 
@@ -1901,8 +1902,7 @@ package body Prj is
               (In_Aggregate_Lib      => True,
                From_Encapsulated_Lib =>
                  Context.From_Encapsulated_Lib
-                   or else
+                   or else Project.Standalone_Library = Encapsulated);
-                 Project.Standalone_Library = Encapsulated);
 
             Agg := Project.Aggregated_Projects;
             while Agg /= null loop
@@ -1912,6 +1912,8 @@ package body Prj is
          end if;
       end Recursive_Process;
 
+   --  Start of processing for For_Project_And_Aggregated_Context
+
    begin
       Recursive_Process
         (Root_Project, Root_Tree, Project_Context'(False, False));

gcc/ada/prj.ads

@@ -1621,7 +1621,7 @@ package Prj is
       With_State         : in out State;
       Include_Aggregated : Boolean := True;
       Imported_First     : Boolean := False);
-   --  As above but with an associated context
+   --  As for For_Every_Project_Imported but with an associated context
 
    generic
       with procedure Action
@@ -1631,7 +1631,7 @@ package Prj is
    procedure For_Project_And_Aggregated_Context
      (Root_Project : Project_Id;
       Root_Tree    : Project_Tree_Ref);
-   --  As above but with an associated context
+   --  As for For_Project_And_Aggregated but with an associated context
 
    function Extend_Name
      (File        : File_Name_Type;

gcc/ada/s-os_lib.adb

@@ -1695,12 +1695,11 @@ package body System.OS_Lib is
                else
                   Res (J) := Arg (K);
                end if;
-
             end loop;
 
             if Quote_Needed then
 
-               --  If null terminated string, put the quote before
+               --  Case of null terminated string
 
                if Res (J) = ASCII.NUL then
 
@@ -1711,7 +1710,7 @@ package body System.OS_Lib is
                      J := J + 1;
                   end if;
 
-                  --  Then adds the quote and the NUL character
+                  --  Put a quote just before the null at the end
 
                   Res (J) := '"';
                   J := J + 1;

gcc/ada/s-tasren.adb

@@ -110,8 +110,8 @@ package body System.Tasking.Rendezvous is
    procedure Local_Complete_Rendezvous (Ex : Ada.Exceptions.Exception_Id);
    --  Internal version of Complete_Rendezvous, used to implement
    --  Complete_Rendezvous and Exceptional_Complete_Rendezvous.
-   --  Should be called holding no locks, generally with abort not yet
+   --  Should be called holding no locks, generally with abort
-   --  deferred.
+   --  not yet deferred.
 
    procedure Boost_Priority (Call : Entry_Call_Link; Acceptor : Task_Id);
    pragma Inline (Boost_Priority);
@@ -538,7 +538,7 @@ package body System.Tasking.Rendezvous is
       Called_PO              : STPE.Protection_Entries_Access;
       Acceptor_Prev_Priority : Integer;
 
-      Ceiling_Violation  : Boolean;
+      Ceiling_Violation : Boolean;
 
       use type Ada.Exceptions.Exception_Id;
       procedure Transfer_Occurrence

gcc/ada/sem_ch6.adb

@@ -188,9 +188,9 @@ package body Sem_Ch6 is
       New_E  : Entity_Id) return Boolean;
    --  Enforce the rule given in 12.3(18): a private operation in an instance
    --  overrides an inherited operation only if the corresponding operation
-   --  was overriding in the generic. This can happen for primitive operations
+   --  was overriding in the generic. This needs to be checked for primitive
-   --  of types derived (in the generic unit) from formal private or formal
+   --  operations of types derived (in the generic unit) from formal private
-   --  derived types.
+   --  or formal derived types.
 
    procedure Make_Inequality_Operator (S : Entity_Id);
    --  Create the declaration for an inequality operator that is implicitly
@@ -7844,6 +7844,22 @@ package body Sem_Ch6 is
                --  If no match found, then the new subprogram does not
                --  override in the generic (nor in the instance).
 
+               --  If the type in question is not abstract, and the subprogram
+               --  is, this will be an error if the new operation is in the
+               --  private part of the instance. Emit a warning now, which will
+               --  make the subsequent error message easier to understand.
+
+               if not Is_Abstract_Type (F_Typ)
+                 and then Is_Abstract_Subprogram (Prev_E)
+                 and then In_Private_Part (Current_Scope)
+               then
+                  Error_Msg_Node_2 := F_Typ;
+                  Error_Msg_NE
+                    ("private operation& in generic unit does not override " &
+                     "any primitive operation of& (RM 12.3 (18))?",
+                     New_E, New_E);
+               end if;
+
                return True;
             end;
          end if;

gcc/ada/sem_dim.adb

@@ -2247,7 +2247,8 @@ package body Sem_Dim is
                   Package_Name := Chars (Ent);
 
                   if Package_Name = Name_Float_IO
-                    or else Package_Name = Name_Integer_IO
+                       or else
+                     Package_Name = Name_Integer_IO
                   then
                      return Chars (Scope (Ent)) = Name_Dim;
                   end if;
@@ -2512,10 +2513,13 @@ package body Sem_Dim is
       if Is_Entity_Name (Gen_Id) then
          Ent := Entity (Gen_Id);
 
+         --  Is it really OK just to test names ??? why???
+
          if Is_Library_Level_Entity (Ent)
            and then
             (Chars (Ent) = Name_Float_IO
-               or else Chars (Ent) = Name_Integer_IO)
+               or else
+             Chars (Ent) = Name_Integer_IO)
          then
             return Chars (Scope (Ent)) = Name_Dim;
          end if;

gcc/ada/sem_dim.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---           Copyright (C) 2011-2012, Free Software Foundation, Inc.        --
+--          Copyright (C) 2011-2012, 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- --

gcc/ada/sem_res.adb

@@ -4239,8 +4239,8 @@ package body Sem_Res is
            and then Nkind (Expression (E)) = N_Function_Call
          then
             declare
-               Pool : constant Entity_Id
+               Pool : constant Entity_Id :=
-                        := Associated_Storage_Pool (Root_Type (Typ));
+                        Associated_Storage_Pool (Root_Type (Typ));
             begin
                if Present (Pool)
                  and then

gcc/ada/sinput.adb

@@ -250,6 +250,10 @@ package body Sinput is
       return Name_Buffer (1 .. Name_Len);
    end Build_Location_String;
 
+   -------------------
+   -- Check_For_BOM --
+   -------------------
+
    procedure Check_For_BOM is
       BOM : BOM_Kind;
       Len : Natural;

gcc/ada/sinput.ads

@@ -544,6 +544,14 @@ package Sinput is
    --  Functional form returning a string, which does not include a terminating
    --  null character. The contents of Name_Buffer is destroyed.
 
+   procedure Check_For_BOM;
+   --  Check if the current source starts with a BOM. Scan_Ptr needs to be at
+   --  the start of the current source. If the current source starts with a
+   --  recognized BOM, then some flags such as Wide_Character_Encoding_Method
+   --  are set accordingly, and the Scan_Ptr on return points past this BOM.
+   --  An error message is output and Unrecoverable_Error raised if a non-
+   --  recognized BOM is detected. The call has no effect if no BOM is found.
+
    function Get_Column_Number (P : Source_Ptr) return Column_Number;
    --  The ones-origin column number of the specified Source_Ptr value is
    --  determined and returned. Tab characters if present are assumed to
@@ -712,16 +720,6 @@ package Sinput is
    --  Writes out internal tables to current tree file using the relevant
    --  Table.Tree_Write routines.
 
-   procedure Check_For_BOM;
-   --  Check if the current source starts with a BOM. Scan_Ptr needs to be at
-   --  the start of the current source.
-   --  If the current source starts with a recognized BOM, then some flags
-   --  such as Wide_Character_Encoding_Method are set accordingly.
-   --  An exception is raised if a BOM is found that indicates an unrecognized
-   --  format.
-   --  This procedure has no effect if there is no BOM at the beginning of the
-   --  current source.
-
 private
    pragma Inline (File_Name);
    pragma Inline (First_Mapped_Line);