From: charlet Date: Mon, 29 Aug 2011 14:32:43 +0000 (+0000) Subject: 2011-08-29 Robert Dewar X-Git-Url: http://git.sourceforge.jp/view?p=pf3gnuchains%2Fgcc-fork.git;a=commitdiff_plain;h=1dceb63e5940445ceb877e01145ff4b1f5d5dc83 2011-08-29 Robert Dewar * impunit.adb, exp_ch4.adb, s-finmas.adb: Minor reformatting. 2011-08-29 Thomas Quinot * exp_dist.adb (TC_Rec_Add_Process_Element): For a choice with multiple values, we generate multiple triples of parameters in the TypeCode. Bump Choice_Index for each such triple so that a subsequent default choice is associated with the correct index in the typecode. 2011-08-29 Ed Schonberg * a-cdlili.adb (Iterate): Initialize properly an iterator over a null container. (First, Last): Handle properly an iterator over a null container. 2011-08-29 Bob Duff * sem_ch10.adb (Analyze_With_Clause,Install_Withed_Unit): Abandon processing if we run across a node with no Scope. This can happen if we're with-ing an library-level instance, and that instance got errors that caused "instantiation abandoned". * sem_util.adb (Unit_Declaration_Node): Make it more robust, by raising an exception instead of using Assert, so it won't go into an infinite loop, even when assertions are turned off. 2011-08-29 Ed Schonberg * a-coorse.adb: Proper handling of empty ordered sets. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@178249 138bc75d-0d04-0410-961f-82ee72b054a4 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 00c9e10909d..b2f77e1fabb 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,34 @@ +2011-08-29 Robert Dewar + + * impunit.adb, exp_ch4.adb, s-finmas.adb: Minor reformatting. + +2011-08-29 Thomas Quinot + + * exp_dist.adb (TC_Rec_Add_Process_Element): For a choice with multiple + values, we generate multiple triples of parameters in the TypeCode. + Bump Choice_Index for each such triple so that a subsequent default + choice is associated with the correct index in the typecode. + +2011-08-29 Ed Schonberg + + * a-cdlili.adb (Iterate): Initialize properly an iterator over a null + container. + (First, Last): Handle properly an iterator over a null container. + +2011-08-29 Bob Duff + + * sem_ch10.adb (Analyze_With_Clause,Install_Withed_Unit): Abandon + processing if we run across a node with no Scope. This can happen if + we're with-ing an library-level instance, and that instance got errors + that caused "instantiation abandoned". + * sem_util.adb (Unit_Declaration_Node): Make it more robust, by raising + an exception instead of using Assert, so it won't go into an infinite + loop, even when assertions are turned off. + +2011-08-29 Ed Schonberg + + * a-coorse.adb: Proper handling of empty ordered sets. + 2011-08-29 Johannes Kanig * debug.adb: Add comments. diff --git a/gcc/ada/a-cdlili.adb b/gcc/ada/a-cdlili.adb index 4682ffbea50..ef02e460cce 100644 --- a/gcc/ada/a-cdlili.adb +++ b/gcc/ada/a-cdlili.adb @@ -412,9 +412,12 @@ package body Ada.Containers.Doubly_Linked_Lists is end First; function First (Object : Iterator) return Cursor is - C : constant Cursor := (Object.Container, Object.Container.First); begin - return C; + if Object.Container = null then + return No_Element; + else + return (Object.Container, Object.Container.First); + end if; end First; ------------------- @@ -819,9 +822,12 @@ package body Ada.Containers.Doubly_Linked_Lists is function Iterate (Container : List) return List_Iterator_Interfaces.Reversible_Iterator'class is - It : constant Iterator := (Container'Unchecked_Access, Container.First); begin - return It; + if Container.Length = 0 then + return Iterator'(null, null); + else + return Iterator'(Container'Unchecked_Access, Container.First); + end if; end Iterate; function Iterate (Container : List; Start : Cursor) @@ -846,9 +852,12 @@ package body Ada.Containers.Doubly_Linked_Lists is end Last; function Last (Object : Iterator) return Cursor is - C : constant Cursor := (Object.Container, Object.Container.Last); begin - return C; + if Object.Container = null then + return No_Element; + else + return (Object.Container, Object.Container.Last); + end if; end Last; ------------------ diff --git a/gcc/ada/a-cidlli.adb b/gcc/ada/a-cidlli.adb index 5ebd2a9d2b2..849cb53c64a 100644 --- a/gcc/ada/a-cidlli.adb +++ b/gcc/ada/a-cidlli.adb @@ -451,7 +451,11 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is function First (Object : Iterator) return Cursor is begin - return Cursor'(Object.Container, Object.Container.First); + if Object.Container = null then + return No_Element; + else + return Cursor'(Object.Container, Object.Container.First); + end if; end First; ------------------- @@ -847,9 +851,12 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is (Container : List) return List_Iterator_Interfaces.Reversible_Iterator'class is - It : constant Iterator := (Container'Unchecked_Access, Container.First); begin - return It; + if Container.Length = 0 then + return Iterator'(null, null); + else + return Iterator'(Container'Unchecked_Access, Container.First); + end if; end Iterate; function Iterate @@ -877,11 +884,11 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is function Last (Object : Iterator) return Cursor is begin - if Object.Container.Last = null then + if Object.Container = null then return No_Element; + else + return Cursor'(Object.Container, Object.Container.Last); end if; - - return Cursor'(Object.Container, Object.Container.Last); end Last; ------------------ diff --git a/gcc/ada/a-coorse.adb b/gcc/ada/a-coorse.adb index b7d9d45dc03..668bd739e84 100644 --- a/gcc/ada/a-coorse.adb +++ b/gcc/ada/a-coorse.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2011, 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- -- @@ -532,8 +532,13 @@ package body Ada.Containers.Ordered_Sets is function First (Object : Iterator) return Cursor is begin - return Cursor'( - Object.Container.all'Unrestricted_Access, Object.Container.Tree.First); + if Object.Container = null then + return No_Element; + else + return Cursor'( + Object.Container.all'Unrestricted_Access, + Object.Container.Tree.First); + end if; end First; ------------------- @@ -1142,10 +1147,12 @@ package body Ada.Containers.Ordered_Sets is function Iterate (Container : Set) return Ordered_Set_Iterator_Interfaces.Reversible_Iterator'class is - It : constant Iterator := - (Container'Unchecked_Access, Container.Tree.First); begin - return It; + if Container.Length = 0 then + return Iterator'(null, null); + else + return Iterator'(Container'Unchecked_Access, Container.Tree.First); + end if; end Iterate; function Iterate (Container : Set; Start : Cursor) @@ -1171,7 +1178,7 @@ package body Ada.Containers.Ordered_Sets is function Last (Object : Iterator) return Cursor is begin - if Object.Container.Tree.Last = null then + if Object.Container = null then return No_Element; end if; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 4824df02583..e3f9412393b 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -664,6 +664,8 @@ package body Exp_Ch4 is -- Start of processing for Expand_Allocator_Expression begin + -- WOuld be nice to comment the branches of this very long if ??? + if Is_Tagged_Type (T) or else Needs_Finalization (T) then @@ -1136,6 +1138,7 @@ package body Exp_Ch4 is Rewrite (Exp, New_Copy (Expression (Exp))); end if; + else Build_Allocate_Deallocate_Proc (N, True); diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb index df6ead34f9d..1f59c7ae09c 100644 --- a/gcc/ada/exp_dist.adb +++ b/gcc/ada/exp_dist.adb @@ -2084,8 +2084,7 @@ package body Exp_Dist is is N : constant Name_Id := Chars (Def); - Overload_Order : constant Int := - Overload_Counter_Table.Get (N) + 1; + Overload_Order : constant Int := Overload_Counter_Table.Get (N) + 1; begin Overload_Counter_Table.Set (N, Overload_Order); @@ -10429,7 +10428,7 @@ package body Exp_Dist is -- A variant part - declare + Variant_Part : declare Disc_Type : constant Entity_Id := Etype (Name (Field)); Is_Enum : constant Boolean := @@ -10451,6 +10450,8 @@ package body Exp_Dist is Dummy_Counter : Int := 0; Choice_Index : Int := 0; + -- Index of current choice in TypeCode, used to identify + -- it as the default choice if it is a "when others". procedure Add_Params_For_Variant_Components; -- Add a struct TypeCode and a corresponding member name @@ -10489,6 +10490,8 @@ package body Exp_Dist is Add_String_Parameter (Name_Str, Union_TC_Params); end Add_Params_For_Variant_Components; + -- Start of processing for Variant_Part + begin Get_Name_String (U_Name); Name_Str := String_From_Name_Buffer; @@ -10547,6 +10550,8 @@ package body Exp_Dist is Add_Params_For_Variant_Components; J := J + Uint_1; end loop; + Choice_Index := + Choice_Index + UI_To_Int (H - L) + 1; end; when N_Others_Choice => @@ -10556,26 +10561,16 @@ package body Exp_Dist is -- current choice index. This parameter is by -- construction the 4th in Union_TC_Params. - declare - Default_Node : constant Node_Id := - Pick (Union_TC_Params, 4); - - New_Default_Node : constant Node_Id := - Make_Function_Call (Loc, - Name => - New_Occurrence_Of - (RTE (RE_TA_I32), Loc), - Parameter_Associations => - New_List ( - Make_Integer_Literal (Loc, - Intval => Choice_Index))); - - begin - Insert_Before - (Default_Node, New_Default_Node); - - Remove (Default_Node); - end; + Replace + (Pick (Union_TC_Params, 4), + Make_Function_Call (Loc, + Name => + New_Occurrence_Of + (RTE (RE_TA_I32), Loc), + Parameter_Associations => + New_List ( + Make_Integer_Literal (Loc, + Intval => Choice_Index)))); -- Add a placeholder member label for the -- default case, which must have the @@ -10594,6 +10589,7 @@ package body Exp_Dist is end; Add_Params_For_Variant_Components; + Choice_Index := Choice_Index + 1; when others => @@ -10608,15 +10604,15 @@ package body Exp_Dist is end; Add_Params_For_Variant_Components; + Choice_Index := Choice_Index + 1; end case; Next (Choice); - Choice_Index := Choice_Index + 1; end loop; Next_Non_Pragma (Variant); end loop; - end; + end Variant_Part; end if; end TC_Rec_Add_Process_Element; diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb index 9aa86d523f6..87498d85f30 100644 --- a/gcc/ada/impunit.adb +++ b/gcc/ada/impunit.adb @@ -524,9 +524,9 @@ package body Impunit is "a-synbar", -- Ada.Synchronous_Barriers "a-undesu", -- Ada.Unchecked_Deallocate_Subpool - ----------------------------------------- - -- GNAT Defined Additions to Ada 20012 -- - ----------------------------------------- + ---------------------------------------- + -- GNAT Defined Additions to Ada 2012 -- + ---------------------------------------- "a-cofove", -- Ada.Containers.Formal_Vectors "a-cfdlli", -- Ada.Containers.Formal_Doubly_Linked_Lists diff --git a/gcc/ada/s-finmas.adb b/gcc/ada/s-finmas.adb index 72b87dfe462..a08bb08a494 100644 --- a/gcc/ada/s-finmas.adb +++ b/gcc/ada/s-finmas.adb @@ -29,7 +29,8 @@ -- -- ------------------------------------------------------------------------------ -with Ada.Exceptions; use Ada.Exceptions; +with Ada.Exceptions; use Ada.Exceptions; + with System.Address_Image; with System.HTable; use System.HTable; with System.IO; use System.IO; @@ -241,12 +242,10 @@ package body System.Finalization_Masters is (Obj : System.Address) return Finalize_Address_Ptr is Result : Finalize_Address_Ptr; - begin Lock_Task.all; Result := Finalize_Address_Table.Get (Obj); Unlock_Task.all; - return Result; end Finalize_Address; diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 59ec7a4b051..2ab7084a11c 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -2585,6 +2585,13 @@ package body Sem_Ch10 is if Par_Name /= Standard_Standard then Par_Name := Scope (Par_Name); end if; + + -- Abandon processing in case of previous errors + + if No (Par_Name) then + pragma Assert (Serious_Errors_Detected /= 0); + return; + end if; end loop; if Present (Entity (Pref)) @@ -5034,6 +5041,13 @@ package body Sem_Ch10 is ("instantiation depends on itself", Name (With_Clause)); elsif not Is_Visible_Child_Unit (Uname) then + -- Abandon processing in case of previous errors + + if No (Scope (Uname)) then + pragma Assert (Serious_Errors_Detected /= 0); + return; + end if; + Set_Is_Visible_Child_Unit (Uname); -- If the child unit appears in the context of its parent, it is diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index b51719d0af2..eab20bf9efe 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -12638,7 +12638,13 @@ package body Sem_Util is and then Nkind (N) not in N_Generic_Renaming_Declaration loop N := Parent (N); - pragma Assert (Present (N)); + + -- We don't use Assert here, because that causes an infinite loop + -- when assertions are turned off. Better to crash. + + if No (N) then + raise Program_Error; + end if; end loop; return N;