diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 7650b76f5b8b6269ca416ddd2f1697b8d5067b29..4c2d48092bb8f788ada1a66ad7cff2543c646952 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,14 @@
+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,
diff --git a/gcc/ada/a-cihama.adb b/gcc/ada/a-cihama.adb
index 5b79df9b69e6ff37c29df8ee1341a86d4c83b5ff..c948f460dc2aee54d7f93adb00337927cc1cb3f6 100644
--- a/gcc/ada/a-cihama.adb
+++ b/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 "=";
diff --git a/gcc/ada/a-cihama.ads b/gcc/ada/a-cihama.ads
index eece9ca8e768505d5eba1f38a85dafb8e41ffdbd..df66249bdddc4acc739eff7eb392c67d50368ed7 100644
--- a/gcc/ada/a-cihama.ads
+++ b/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
diff --git a/gcc/ada/a-coinve.adb b/gcc/ada/a-coinve.adb
index 6a50f9f05419b25715a5792bcf3fd30a017556a1..f7fc5abf9b0a6889911c8f852e5fb09a2ecf8cce 100644
--- a/gcc/ada/a-coinve.adb
+++ b/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;
diff --git a/gcc/ada/a-coinve.ads b/gcc/ada/a-coinve.ads
index 0026272d10523bff79582519106170df4a0645bc..721f134717d8eb3025919b4f02e0f6c543016433 100644
--- a/gcc/ada/a-coinve.ads
+++ b/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;
diff --git a/gcc/ada/a-convec.adb b/gcc/ada/a-convec.adb
index 6175c2f3daa7911d3f20fedc0d5efa6b8472d375..b4668a4870367d8b7a56ff91faf1d26ef3a61b21 100644
--- a/gcc/ada/a-convec.adb
+++ b/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;
diff --git a/gcc/ada/a-convec.ads b/gcc/ada/a-convec.ads
index 9dc5c547162cb11dc7fa358f1dfae1d64a5b32ec..bcb2734ea931a609e5a34a946843e20bc017217b 100644
--- a/gcc/ada/a-convec.ads
+++ b/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;
diff --git a/gcc/ada/a-filico.ads b/gcc/ada/a-filico.ads
index b6aca172f9d7f0adf3fb4f276080ee97ec29598c..5768dfdda8aacfb81d8154a610a5e49cca7fb65a 100644
--- a/gcc/ada/a-filico.ads
+++ b/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;
diff --git a/gcc/ada/a-finali.adb b/gcc/ada/a-finali.adb
index 92ba21d6422ac25171e261985af7dbcd0bee4732..7137e23183a4f4e0ca62ff335090f8618efe0d33 100644
--- a/gcc/ada/a-finali.adb
+++ b/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 "=";
diff --git a/gcc/ada/a-finali.ads b/gcc/ada/a-finali.ads
index 0eb3c0303cf6396056c232bd2c823b5fd047e2a7..fa983a4556b188df4362d9fcecdb577ac5135313 100644
--- a/gcc/ada/a-finali.ads
+++ b/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;
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index f49afe7e7e014e749b86236f131dfa08d0409c08..53a9c9a2a7b79237ac803c7b41169c78f2a536a6 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/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;
diff --git a/gcc/ada/s-finimp.adb b/gcc/ada/s-finimp.adb
index 225e461e1200b3582cbbed1af73282addd22c208..d5bf0c1f9d421f84b0a23c119b7f8d7a7182f728 100644
--- a/gcc/ada/s-finimp.adb
+++ b/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;
diff --git a/gcc/ada/s-finimp.ads b/gcc/ada/s-finimp.ads
index 7895326f85f0fb894c557c326c60131606ec8e11..e9ffeae7ffc2f7c8ffa4afcaa43eb1ec17cb499e 100644
--- a/gcc/ada/s-finimp.ads
+++ b/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.
diff --git a/gcc/ada/s-tpoben.adb b/gcc/ada/s-tpoben.adb
index 38126956b9e1b15c91a2ed4cc3ad2c36c52e860b..d6d83778ddddf2b63ee75100d4c4c202aacba961 100644
--- a/gcc/ada/s-tpoben.adb
+++ b/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;
diff --git a/gcc/ada/s-tpoben.ads b/gcc/ada/s-tpoben.ads
index b3dea7b03d2229d07e3c5da19ca2b20654d02b8c..059ea2557e9f237791850f78e77a07dc73bc2416 100644
--- a/gcc/ada/s-tpoben.ads
+++ b/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.