[multiple changes]

2009-04-09  Robert Dewar  <dewar@adacore.com>

	* exp_ch4.adb (Expand_Concatenate): Improve handling of overflow cases

2009-04-09  Pascal Obry  <obry@adacore.com>

	* a-cihama.adb, a-cihama.ads, a-coinve.adb, a-coinve.ads,
	s-tpoben.adb, s-tpoben.ads, s-finimp.adb, s-finimp.ads,
	a-convec.adb, a-convec.ads, a-finali.adb, a-finali.ads,
	a-filico.ads: Add some missing overriding keywords.

From-SVN: r145807

gcc/ada/ChangeLog

+2009-04-09  Robert Dewar  <dewar@adacore.com>
+
+	* exp_ch4.adb (Expand_Concatenate): Improve handling of overflow cases
+
+2009-04-09  Pascal Obry  <obry@adacore.com>
+
+	* a-cihama.adb, a-cihama.ads, a-coinve.adb, a-coinve.ads,
+	s-tpoben.adb, s-tpoben.ads, s-finimp.adb, s-finimp.ads,
+	a-convec.adb, a-convec.ads, a-finali.adb, a-finali.ads,
+	a-filico.ads: Add some missing overriding keywords.
+
 2009-04-09  Pascal Obry  <obry@adacore.com>
 
 	* a-cihama.adb, a-cihama.ads, a-coinve.adb, a-coorma.ads, a-cihase.adb,

gcc/ada/a-cihama.adb

@@ -108,7 +108,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
 
    function Is_Equal is new HT_Ops.Generic_Equal (Find_Equal_Key);
 
-   function "=" (Left, Right : Map) return Boolean is
+   overriding function "=" (Left, Right : Map) return Boolean is
    begin
       return Is_Equal (Left.HT, Right.HT);
    end "=";

gcc/ada/a-cihama.ads

@@ -63,7 +63,7 @@ package Ada.Containers.Indefinite_Hashed_Maps is
    --  Cursor objects declared without an initialization expression are
    --  initialized to the value No_Element.
 
-   function "=" (Left, Right : Map) return Boolean;
+   overriding function "=" (Left, Right : Map) return Boolean;
    --  For each key/element pair in Left, equality attempts to find the key in
    --  Right; if a search fails the equality returns False. The search works by
    --  calling Hash to find the bucket in the Right map that corresponds to the

gcc/ada/a-coinve.adb

@@ -385,7 +385,7 @@ package body Ada.Containers.Indefinite_Vectors is
    -- "=" --
    ---------
 
-   function "=" (Left, Right : Vector) return Boolean is
+   overriding function "=" (Left, Right : Vector) return Boolean is
    begin
       if Left'Address = Right'Address then
          return True;

gcc/ada/a-coinve.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 2004-2007, Free Software Foundation, Inc.         --
+--          Copyright (C) 2004-2008, Free Software Foundation, Inc.         --
 --                                                                          --
 -- This specification is derived from the Ada Reference Manual for use with --
 -- GNAT. The copyright notice above, and the license provisions that follow --
@@ -62,7 +62,7 @@ package Ada.Containers.Indefinite_Vectors is
 
    No_Element : constant Cursor;
 
-   function "=" (Left, Right : Vector) return Boolean;
+   overriding function "=" (Left, Right : Vector) return Boolean;
 
    function To_Vector (Length : Count_Type) return Vector;
 

gcc/ada/a-convec.adb

@@ -232,7 +232,7 @@ package body Ada.Containers.Vectors is
    -- "=" --
    ---------
 
-   function "=" (Left, Right : Vector) return Boolean is
+   overriding function "=" (Left, Right : Vector) return Boolean is
    begin
       if Left'Address = Right'Address then
          return True;

gcc/ada/a-convec.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 2004-2007, Free Software Foundation, Inc.         --
+--          Copyright (C) 2004-2008, Free Software Foundation, Inc.         --
 --                                                                          --
 -- This specification is derived from the Ada Reference Manual for use with --
 -- GNAT. The copyright notice above, and the license provisions that follow --
@@ -62,7 +62,7 @@ package Ada.Containers.Vectors is
 
    No_Element : constant Cursor;
 
-   function "=" (Left, Right : Vector) return Boolean;
+   overriding function "=" (Left, Right : Vector) return Boolean;
 
    function To_Vector (Length : Count_Type) return Vector;
 

gcc/ada/a-filico.ads

@@ -52,7 +52,7 @@ package Ada.Finalization.List_Controller is
       --  while those temporaries are still in use, they will be reclaimed
       --  by the normal finalization mechanism.
 
-   procedure Finalize (Object : in out Simple_List_Controller);
+   overriding procedure Finalize (Object : in out Simple_List_Controller);
 
    ---------------------
    -- List_Controller --
@@ -98,7 +98,7 @@ package Ada.Finalization.List_Controller is
    --  objects makes sure that they get finalized upon exit from
    --  the access type that defined them
 
-   procedure Initialize (Object : in out List_Controller);
-   procedure Finalize   (Object : in out List_Controller);
+   overriding procedure Initialize (Object : in out List_Controller);
+   overriding procedure Finalize   (Object : in out List_Controller);
 
 end Ada.Finalization.List_Controller;

gcc/ada/a-finali.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2006, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2008, 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- --
@@ -39,7 +39,7 @@ package body Ada.Finalization is
    -- "=" --
    ---------
 
-   function "=" (A, B : Controlled) return Boolean is
+   overriding function "=" (A, B : Controlled) return Boolean is
    begin
       return Empty_Root_Controlled (A) = Empty_Root_Controlled (B);
    end "=";

gcc/ada/a-finali.ads

@@ -63,9 +63,9 @@ private
 
    type Controlled is abstract new SFR.Root_Controlled with null record;
 
-   function "=" (A, B : Controlled) return Boolean;
+   overriding function "=" (A, B : Controlled) return Boolean;
    --  Need to be defined explicitly because we don't want to compare the
-   --  hidden pointers
+   --  hidden pointers.
 
    type Limited_Controlled is
      abstract new SFR.Root_Controlled with null record;

gcc/ada/exp_ch4.adb

@@ -3,7 +3,7 @@
 --                         GNAT COMPILER COMPONENTS                         --
 --                                                                          --
 --                              E X P _ C H 4                               --
---                                                                          --
+--                                                               g           --
 --                                 B o d y                                  --
 --                                                                          --
 --          Copyright (C) 1992-2008, Free Software Foundation, Inc.         --
@@ -2230,6 +2230,17 @@ package body Exp_Ch4 is
       Result : Node_Id;
       --  Result of the concatenation (of type Ityp)
 
+      Known_Non_Null_Operand_Seen : Boolean;
+      --  Set True during generation of the assignements of operands into
+      --  result once an operand known to be non-null has been seen.
+
+      function Make_Artyp_Literal (Val : Nat) return Node_Id;
+      --  This function makes an N_Integer_Literal node that is returned in
+      --  analyzed form with the type set to Artyp. Importantly this literal
+      --  is not flagged as static, so that if we do computations with it that
+      --  result in statically detected out of range conditions, we will not
+      --  generate error messages but instead warning messages.
+
       function To_Artyp (X : Node_Id) return Node_Id;
       --  Given a node of type Ityp, returns the corresponding value of type
       --  Artyp. For non-enumeration types, this is a plain integer conversion.
@@ -2238,9 +2249,18 @@ package body Exp_Ch4 is
       function To_Ityp (X : Node_Id) return Node_Id;
       --  The inverse function (uses Val in the case of enumeration types)
 
-      Known_Non_Null_Operand_Seen : Boolean;
-      --  Set True during generation of the assignements of operands into
-      --  result once an operand known to be non-null has been seen.
+      ------------------------
+      -- Make_Artyp_Literal --
+      ------------------------
+
+      function Make_Artyp_Literal (Val : Nat) return Node_Id is
+         Result : constant Node_Id := Make_Integer_Literal (Loc, Val);
+      begin
+         Set_Etype (Result, Artyp);
+         Set_Analyzed (Result, True);
+         Set_Is_Static_Expression (Result, False);
+         return Result;
+      end Make_Artyp_Literal;
 
       --------------
       -- To_Artyp --
@@ -2296,11 +2316,7 @@ package body Exp_Ch4 is
       Clen     : Node_Id;
       Set      : Boolean;
 
-      Saved_In_Inlined_Body : Boolean;
-
    begin
-      Aggr_Length (0) := Make_Integer_Literal (Loc, 0);
-
       --  Choose an appropriate computational type
 
       --  We will be doing calculations of lengths and bounds in this routine
@@ -2346,6 +2362,10 @@ package body Exp_Ch4 is
          end if;
       end if;
 
+      --  Supply dummy entry at start of length array
+
+      Aggr_Length (0) := Make_Artyp_Literal (0);
+
       --  Go through operands setting up the above arrays
 
       J := 1;
@@ -2397,7 +2417,7 @@ package body Exp_Ch4 is
                  Make_Op_Add (Loc,
                    Left_Opnd  =>
                      New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ)),
-                   Right_Opnd => Make_Integer_Literal (Loc, 1));
+                   Right_Opnd => Make_Artyp_Literal (1));
             end if;
 
             --  Skip null string literal
@@ -2707,7 +2727,7 @@ package body Exp_Ch4 is
             Right_Opnd =>
               Make_Op_Subtract (Loc,
                 Left_Opnd  => New_Copy (Aggr_Length (NN)),
-                Right_Opnd => Make_Integer_Literal (Loc, 1))));
+                Right_Opnd => Make_Artyp_Literal (1))));
 
       --  Now force overflow checking on High_Bound
 
@@ -2723,7 +2743,7 @@ package body Exp_Ch4 is
              Expressions => New_List (
                Make_Op_Eq (Loc,
                  Left_Opnd  => New_Copy (Aggr_Length (NN)),
-                 Right_Opnd => Make_Integer_Literal (Loc, 0)),
+                 Right_Opnd => Make_Artyp_Literal (0)),
                Last_Opnd_High_Bound,
                High_Bound));
       end if;
@@ -2734,16 +2754,10 @@ package body Exp_Ch4 is
         Make_Defining_Identifier (Loc,
           Chars => New_Internal_Name ('S'));
 
-      --  Kludge! Kludge! ???
       --  If the bound is statically known to be out of range, we do not want
-      --  to abort, we want a warning and a runtime constraint error, so we
-      --  pretend this comes from an inlined body (otherwise a static out
-      --  of range value would be an illegality).
-
-      --  This is horrible, we really must find a better way ???
-
-      Saved_In_Inlined_Body := In_Inlined_Body;
-      In_Inlined_Body := True;
+      --  to abort, we want a warning and a runtime constraint error. Note that
+      --  we have arranged that the result will not be treated as a static
+      --  constant, so we won't get an illegality during this insertion.
 
       Insert_Action (Cnode,
         Make_Object_Declaration (Loc,
@@ -2759,8 +2773,6 @@ package body Exp_Ch4 is
                       High_Bound => High_Bound))))),
         Suppress => All_Checks);
 
-      In_Inlined_Body := Saved_In_Inlined_Body;
-
       --  Catch the static out of range case now
 
       if Raises_Constraint_Error (High_Bound) then
@@ -2784,7 +2796,7 @@ package body Exp_Ch4 is
                      Right_Opnd =>
                        Make_Op_Subtract (Loc,
                          Left_Opnd  => Aggr_Length (J),
-                         Right_Opnd => Make_Integer_Literal (Loc, 1)));
+                         Right_Opnd => Make_Artyp_Literal (1)));
 
          begin
             --  Singleton case, simple assignment
@@ -2839,6 +2851,7 @@ package body Exp_Ch4 is
                          Then_Statements =>
                            New_List (Assign));
                   end if;
+
                   Insert_Action (Cnode, Assign, Suppress => All_Checks);
                end;
             end if;

gcc/ada/s-finimp.adb

@@ -90,11 +90,11 @@ package body System.Finalization_Implementation is
    -- Adjust --
    ------------
 
-   procedure Adjust (Object : in out Record_Controller) is
+   overriding procedure Adjust (Object : in out Record_Controller) is
 
       First_Comp : Finalizable_Ptr;
-      My_Offset : constant SSE.Storage_Offset :=
-                    Object.My_Address - Object'Address;
+      My_Offset  : constant SSE.Storage_Offset :=
+                     Object.My_Address - Object'Address;
 
       procedure Ptr_Adjust (Ptr : in out Finalizable_Ptr);
       --  Subtract the offset to the pointer
@@ -125,7 +125,7 @@ package body System.Finalization_Implementation is
             Ptr_Adjust (P.Next);
             Reverse_Adjust (P.Next);
             Adjust (P.all);
-            Object.F := P;   --  Successfully adjusted, so place in list.
+            Object.F := P;   --  Successfully adjusted, so place in list
          end if;
       end Reverse_Adjust;
 
@@ -263,7 +263,6 @@ package body System.Finalization_Implementation is
 
    procedure Detach_From_Final_List (Obj : in out Finalizable) is
    begin
-
       --  When objects are not properly attached to a doubly linked list do
       --  not try to detach them. The only case where it can happen is when
       --  dealing with Finalize_Storage_Only objects which are not always
@@ -293,7 +292,7 @@ package body System.Finalization_Implementation is
    -- Finalize --
    --------------
 
-   procedure Finalize   (Object : in out Limited_Record_Controller) is
+   overriding procedure Finalize (Object : in out Limited_Record_Controller) is
    begin
       Finalize_List (Object.F);
    end Finalize;
@@ -392,7 +391,7 @@ package body System.Finalization_Implementation is
 
    begin
       --  Fetch the controller from the Parent or above if necessary
-      --  when there are no controller at this level
+      --  when there are no controller at this level.
 
       while Offset = -2 loop
          The_Tag := Ada.Tags.Parent_Tag (The_Tag);
@@ -455,13 +454,15 @@ package body System.Finalization_Implementation is
    -- Initialize --
    ----------------
 
-   procedure Initialize (Object : in out Limited_Record_Controller) is
+   overriding procedure Initialize
+     (Object : in out Limited_Record_Controller)
+   is
       pragma Warnings (Off, Object);
    begin
       null;
    end Initialize;
 
-   procedure Initialize (Object : in out Record_Controller) is
+   overriding procedure Initialize (Object : in out Record_Controller) is
    begin
       Object.My_Address := Object'Address;
    end Initialize;
@@ -503,8 +504,8 @@ package body System.Finalization_Implementation is
       From_Abort : Boolean;
       E_Occ      : Exception_Occurrence)
    is
-      P   : Finalizable_Ptr := L;
-      Q   : Finalizable_Ptr;
+      P : Finalizable_Ptr := L;
+      Q : Finalizable_Ptr;
 
    begin
       --  We already got an exception. We now finalize the remainder of
@@ -538,5 +539,4 @@ package body System.Finalization_Implementation is
 
 begin
    SSL.Finalize_Global_List := Finalize_Global_List'Access;
-
 end System.Finalization_Implementation;

gcc/ada/s-finimp.ads

@@ -132,10 +132,10 @@ package System.Finalization_Implementation is
       F : SFR.Finalizable_Ptr;
    end record;
 
-   procedure Initialize (Object : in out Limited_Record_Controller);
+   overriding procedure Initialize (Object : in out Limited_Record_Controller);
    --  Does nothing currently
 
-   procedure Finalize (Object : in out Limited_Record_Controller);
+   overriding procedure Finalize (Object : in out Limited_Record_Controller);
    --  Finalize the controlled components of the enclosing record by following
    --  the list starting at Object.F.
 
@@ -144,10 +144,10 @@ package System.Finalization_Implementation is
          My_Address : System.Address;
       end record;
 
-   procedure Initialize (Object : in out Record_Controller);
+   overriding procedure Initialize (Object : in out Record_Controller);
    --  Initialize the field My_Address to the Object'Address
 
-   procedure Adjust (Object : in out Record_Controller);
+   overriding procedure Adjust (Object : in out Record_Controller);
    --  Adjust the components and their finalization pointers by subtracting by
    --  the offset of the target and the source addresses of the assignment.
 

gcc/ada/s-tpoben.adb

@@ -78,7 +78,7 @@ package body System.Tasking.Protected_Objects.Entries is
    -- Finalize --
    --------------
 
-   procedure Finalize (Object : in out Protection_Entries) is
+   overriding procedure Finalize (Object : in out Protection_Entries) is
       Entry_Call        : Entry_Call_Link;
       Caller            : Task_Id;
       Ceiling_Violation : Boolean;

gcc/ada/s-tpoben.ads

@@ -225,7 +225,7 @@ package System.Tasking.Protected_Objects.Entries is
 
 private
 
-   procedure Finalize (Object : in out Protection_Entries);
+   overriding procedure Finalize (Object : in out Protection_Entries);
    --  Clean up a Protection object; in particular, finalize the associated
    --  Lock object.