From fa9693102a090415823003a038b56af6cf9aba0f Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Thu, 9 Apr 2009 10:45:55 +0200 Subject: [multiple changes] 2009-04-09 Robert Dewar * exp_ch4.adb (Expand_Concatenate): Improve handling of overflow cases 2009-04-09 Pascal Obry * 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 | 11 ++++++++++ gcc/ada/a-cihama.adb | 2 +- gcc/ada/a-cihama.ads | 2 +- gcc/ada/a-coinve.adb | 2 +- gcc/ada/a-coinve.ads | 4 ++-- gcc/ada/a-convec.adb | 2 +- gcc/ada/a-convec.ads | 4 ++-- gcc/ada/a-filico.ads | 6 +++--- gcc/ada/a-finali.adb | 4 ++-- gcc/ada/a-finali.ads | 4 ++-- gcc/ada/exp_ch4.adb | 59 ++++++++++++++++++++++++++++++++-------------------- gcc/ada/s-finimp.adb | 24 ++++++++++----------- gcc/ada/s-finimp.ads | 8 +++---- gcc/ada/s-tpoben.adb | 2 +- gcc/ada/s-tpoben.ads | 2 +- 15 files changed, 80 insertions(+), 56 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 7650b76..4c2d480 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,14 @@ +2009-04-09 Robert Dewar + + * exp_ch4.adb (Expand_Concatenate): Improve handling of overflow cases + +2009-04-09 Pascal Obry + + * 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 * 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 5b79df9..c948f46 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 eece9ca..df66249 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 6a50f9f..f7fc5ab 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 0026272..721f134 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 6175c2f..b4668a4 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 9dc5c54..bcb2734 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 b6aca17..5768dfd 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 92ba21d..7137e23 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 0eb3c03..fa983a4 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 f49afe7..53a9c9a 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 225e461..d5bf0c1 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 7895326..e9ffeae 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 3812695..d6d8377 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 b3dea7b..059ea25 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. -- cgit v1.1