OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes]

Browse Source 
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
This commit is contained in:
Arnaud Charlet 2009-04-09 10:45:55 +02:00
parent 0c0efb3346
commit fa9693102a
15 changed files with 80 additions and 56 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
gcc/ada/ChangeLog
View File

@ -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,

2
gcc/ada/a-cihama.adb
View File

@ -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 "=";

2
gcc/ada/a-cihama.ads
View File

@ -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

2
gcc/ada/a-coinve.adb
View File

@ -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;

4
gcc/ada/a-coinve.ads
View File

@ -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;

2
gcc/ada/a-convec.adb
View File

@ -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;

4
gcc/ada/a-convec.ads
View File

@ -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;

6
gcc/ada/a-filico.ads
View File

@ -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;

4
gcc/ada/a-finali.adb
View File

@ -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 "=";

4
gcc/ada/a-finali.ads
View File

@ -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;

59
gcc/ada/exp_ch4.adb
View File

@ -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;

24
gcc/ada/s-finimp.adb
View File

@ -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;

8
gcc/ada/s-finimp.ads
View File

@ -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.

2
gcc/ada/s-tpoben.adb
View File

@ -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;

2
gcc/ada/s-tpoben.ads
View File

@ -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.