diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/ada/ChangeLog | 60 | ||||
| -rw-r--r-- | gcc/ada/a-chtgbo.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/a-except-2005.adb | 96 | ||||
| -rw-r--r-- | gcc/ada/a-except-2005.ads | 4 | ||||
| -rw-r--r-- | gcc/ada/a-except.adb | 68 | ||||
| -rw-r--r-- | gcc/ada/a-except.ads | 4 | ||||
| -rw-r--r-- | gcc/ada/exp_ch5.adb | 170 | ||||
| -rw-r--r-- | gcc/ada/exp_ch7.adb | 111 | ||||
| -rw-r--r-- | gcc/ada/exp_disp.adb | 58 | ||||
| -rw-r--r-- | gcc/ada/par-ch3.adb | 22 | ||||
| -rw-r--r-- | gcc/ada/rtsfind.ads | 2 | ||||
| -rw-r--r-- | gcc/ada/s-stposu.adb | 15 | ||||
| -rw-r--r-- | gcc/ada/sem_ch12.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/sem_ch5.adb | 39 | ||||
| -rw-r--r-- | gcc/ada/sem_ch8.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/sem_res.adb | 19 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 93 |
17 files changed, 446 insertions, 327 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index be0713a634a..82b72fec4b1 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,63 @@ +2011-08-29 Pascal Obry <obry@adacore.com> + + * exp_disp.adb: Minor comment fix. + (Make_Disp_Asynchronous_Select_Body): Properly initialize out parameters + to avoid warnings when compiling with -Wall. + (Make_Disp_Conditional_Select_Body): Likewise. + (Make_Disp_Timed_Select_Body): Likewise. + +2011-08-29 Ed Schonberg <schonberg@adacore.com> + + * sem_ch12.adb (Analyze_Formal_Subprogram_Declaration): If default is + an entity name, generate reference for it. + +2011-08-29 Ed Schonberg <schonberg@adacore.com> + + * exp_ch5.adb (Expand_Iterator_Loop): Uniform handling of "X of S" + iterator form. + * sem_util.adb (Is_Iterator, Is_Reversible_Iterator): Yield True for + the class-wide type. + * sem_ch5.adb: Move some rewriting to the expander, where it belongs. + +2011-08-29 Ed Schonberg <schonberg@adacore.com> + + * sem_ch8.adb (Check_Constrained_Object): Do not create an actual + subtype for an object whose type is an unconstrained union. + +2011-08-29 Ed Schonberg <schonberg@adacore.com> + + * par-ch3.adb (P_Array_Type_Definiation, P_Component_Items): "aliased" + is allowed in a component definition, by AI95-406. + +2011-08-29 Matthew Heaney <heaney@adacore.com> + + * a-chtgbo.adb (Generic_Iteration): Use correct overloading of Next. + +2011-08-29 Hristian Kirtchev <kirtchev@adacore.com> + + * a-except-2005.adb: Alphabetize all routines. + (Triggered_By_Abort): New routine. + * a-except-2005.ads (Triggered_By_Abort): New routine. + * a-except.adb Alphabetize all routines. + (Triggered_By_Abort): New routine. + * a-except.ads (Triggered_By_Abort): New routine. + * exp_ch7.adb: Update all comments involving the detection of aborts in + finalization code. + (Build_Object_Declarations): Do not generate code to detect the + presence of an abort at the start of finalization code, use a runtime + routine istead. + * rtsfind.ads: Add RE_Triggered_By_Abort to tables RE_Id and + RE_Unit_Table. + * sem_res.adb (Resolve_Allocator): Emit a warning when attempting to + allocate a task on a subpool. + * s-stposu.adb: Add library-level flag Finalize_Address_Table_In_Use. + The flag disables all actions related to the maintenance of + Finalize_Address_Table when subpools are not in use. + (Allocate_Any_Controlled): Signal the machinery that subpools are in + use. + (Deallocate_Any_Controlled): Do not call Delete_Finalize_Address which + performs costly task locking when subpools are not in use. + 2011-08-29 Yannick Moy <moy@adacore.com> * gnat1drv.adb (Adjust_Global_Switches): Restore expansion of tagged diff --git a/gcc/ada/a-chtgbo.adb b/gcc/ada/a-chtgbo.adb index fce5dd21a01..a4254697044 100644 --- a/gcc/ada/a-chtgbo.adb +++ b/gcc/ada/a-chtgbo.adb @@ -350,7 +350,7 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is Node := HT.Buckets (Indx); while Node /= 0 loop Process (Node); - Node := Next (HT, Node); + Node := Next (HT.Nodes (Node)); end loop; end loop; end Generic_Iteration; diff --git a/gcc/ada/a-except-2005.adb b/gcc/ada/a-except-2005.adb index cc2409f76ef..0196f921877 100644 --- a/gcc/ada/a-except-2005.adb +++ b/gcc/ada/a-except-2005.adb @@ -762,6 +762,20 @@ package body Ada.Exceptions is -- in case we do not want any exception tracing support. This is -- why this package is separated. + ----------- + -- Image -- + ----------- + + function Image (Index : Integer) return String is + Result : constant String := Integer'Image (Index); + begin + if Result (1) = ' ' then + return Result (2 .. Result'Last); + else + return Result; + end if; + end Image; + ----------------------- -- Stream Attributes -- ----------------------- @@ -848,6 +862,22 @@ package body Ada.Exceptions is Raise_Current_Excep (E); end Raise_Exception_Always; + ------------------------------ + -- Raise_Exception_No_Defer -- + ------------------------------ + + procedure Raise_Exception_No_Defer + (E : Exception_Id; + Message : String := "") + is + begin + Exception_Data.Set_Exception_Msg (E, Message); + + -- Do not call Abort_Defer.all, as specified by the spec + + Raise_Current_Excep (E); + end Raise_Exception_No_Defer; + ------------------------------------- -- Raise_From_Controlled_Operation -- ------------------------------------- @@ -1007,20 +1037,6 @@ package body Ada.Exceptions is Raise_Current_Excep (E); end Raise_With_Msg; - ----------- - -- Image -- - ----------- - - function Image (Index : Integer) return String is - Result : constant String := Integer'Image (Index); - begin - if Result (1) = ' ' then - return Result (2 .. Result'Last); - else - return Result; - end if; - end Image; - -------------------------------------- -- Calls to Run-Time Check Routines -- -------------------------------------- @@ -1319,18 +1335,6 @@ package body Ada.Exceptions is return Target; end Save_Occurrence; - ------------------------- - -- Transfer_Occurrence -- - ------------------------- - - procedure Transfer_Occurrence - (Target : Exception_Occurrence_Access; - Source : Exception_Occurrence) - is - begin - Save_Occurrence (Target.all, Source); - end Transfer_Occurrence; - ------------------- -- String_To_EId -- ------------------- @@ -1345,22 +1349,6 @@ package body Ada.Exceptions is function String_To_EO (S : String) return Exception_Occurrence renames Stream_Attributes.String_To_EO; - ------------------------------ - -- Raise_Exception_No_Defer -- - ------------------------------ - - procedure Raise_Exception_No_Defer - (E : Exception_Id; - Message : String := "") - is - begin - Exception_Data.Set_Exception_Msg (E, Message); - - -- Do not call Abort_Defer.all, as specified by the spec - - Raise_Current_Excep (E); - end Raise_Exception_No_Defer; - --------------- -- To_Stderr -- --------------- @@ -1385,6 +1373,30 @@ package body Ada.Exceptions is end To_Stderr; ------------------------- + -- Transfer_Occurrence -- + ------------------------- + + procedure Transfer_Occurrence + (Target : Exception_Occurrence_Access; + Source : Exception_Occurrence) + is + begin + Save_Occurrence (Target.all, Source); + end Transfer_Occurrence; + + ------------------------ + -- Triggered_By_Abort -- + ------------------------ + + function Triggered_By_Abort return Boolean is + Ex : constant Exception_Occurrence_Access := Get_Current_Excep.all; + + begin + return Ex /= null + and then Exception_Identity (Ex.all) = Standard'Abort_Signal'Identity; + end Triggered_By_Abort; + + ------------------------- -- Wide_Exception_Name -- ------------------------- diff --git a/gcc/ada/a-except-2005.ads b/gcc/ada/a-except-2005.ads index aed0f208754..8457c031d04 100644 --- a/gcc/ada/a-except-2005.ads +++ b/gcc/ada/a-except-2005.ads @@ -250,6 +250,10 @@ private -- occurrence. This is used in generated code when it is known that abort -- is already deferred. + function Triggered_By_Abort return Boolean; + -- Determine whether the current exception (if exists) is an instance of + -- Standard'Abort_Signal. + ----------------------- -- Polling Interface -- ----------------------- diff --git a/gcc/ada/a-except.adb b/gcc/ada/a-except.adb index 9994207585a..415267c7733 100644 --- a/gcc/ada/a-except.adb +++ b/gcc/ada/a-except.adb @@ -807,6 +807,22 @@ package body Ada.Exceptions is Raise_Current_Excep (E); end Raise_Exception_Always; + ------------------------------ + -- Raise_Exception_No_Defer -- + ------------------------------ + + procedure Raise_Exception_No_Defer + (E : Exception_Id; + Message : String := "") + is + begin + Exception_Data.Set_Exception_Msg (E, Message); + + -- Do not call Abort_Defer.all, as specified by the spec + + Raise_Current_Excep (E); + end Raise_Exception_No_Defer; + ------------------------------------- -- Raise_From_Controlled_Operation -- ------------------------------------- @@ -1205,18 +1221,6 @@ package body Ada.Exceptions is return Target; end Save_Occurrence; - ------------------------- - -- Transfer_Occurrence -- - ------------------------- - - procedure Transfer_Occurrence - (Target : Exception_Occurrence_Access; - Source : Exception_Occurrence) - is - begin - Save_Occurrence (Target.all, Source); - end Transfer_Occurrence; - ------------------- -- String_To_EId -- ------------------- @@ -1231,22 +1235,6 @@ package body Ada.Exceptions is function String_To_EO (S : String) return Exception_Occurrence renames Stream_Attributes.String_To_EO; - ------------------------------ - -- Raise_Exception_No_Defer -- - ------------------------------ - - procedure Raise_Exception_No_Defer - (E : Exception_Id; - Message : String := "") - is - begin - Exception_Data.Set_Exception_Msg (E, Message); - - -- Do not call Abort_Defer.all, as specified by the spec - - Raise_Current_Excep (E); - end Raise_Exception_No_Defer; - --------------- -- To_Stderr -- --------------- @@ -1270,4 +1258,28 @@ package body Ada.Exceptions is end loop; end To_Stderr; + ------------------------- + -- Transfer_Occurrence -- + ------------------------- + + procedure Transfer_Occurrence + (Target : Exception_Occurrence_Access; + Source : Exception_Occurrence) + is + begin + Save_Occurrence (Target.all, Source); + end Transfer_Occurrence; + + ------------------------ + -- Triggered_By_Abort -- + ------------------------ + + function Triggered_By_Abort return Boolean is + Ex : constant Exception_Occurrence_Access := Get_Current_Excep.all; + + begin + return Ex /= null + and then Exception_Identity (Ex.all) = Standard'Abort_Signal'Identity; + end Triggered_By_Abort; + end Ada.Exceptions; diff --git a/gcc/ada/a-except.ads b/gcc/ada/a-except.ads index 22f0cee9beb..183bb0bf07c 100644 --- a/gcc/ada/a-except.ads +++ b/gcc/ada/a-except.ads @@ -221,6 +221,10 @@ private -- occurrence. This is used in generated code when it is known that -- abort is already deferred. + function Triggered_By_Abort return Boolean; + -- Determine whether the current exception (if exists) is an instance of + -- Standard'Abort_Signal. + ----------------------- -- Polling Interface -- ----------------------- diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 21b14d725fc..29399d790f8 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -23,6 +23,7 @@ -- -- ------------------------------------------------------------------------------ +with Aspects; use Aspects; with Atree; use Atree; with Checks; use Checks; with Debug; use Debug; @@ -2920,12 +2921,21 @@ package body Exp_Ch5 is declare Element_Type : constant Entity_Id := Etype (Id); + Iter_Type : Entity_Id; Pack : Entity_Id; Decl : Node_Id; Name_Init : Name_Id; Name_Step : Name_Id; begin + + -- The type of the iterator is the return type of the Iterate + -- function used. For the "of" form this is the default iterator + -- for the type, otherwise it is the type of the explicit + -- function used in the loop. + + Iter_Type := Etype (Name (I_Spec)); + if Is_Entity_Name (Container) then Pack := Scope (Etype (Container)); @@ -2934,14 +2944,43 @@ package body Exp_Ch5 is end if; -- The "of" case uses an internally generated cursor whose type - -- is found in the container package. + -- is found in the container package. The domain of iteration + -- is expanded into a call to the default Iterator function, but + -- this expansion does not take place in a quantifier expressions + -- that are analyzed with expansion disabled, and in that case the + -- type of the iterator must be obtained from the aspect. if Of_Present (I_Spec) then - Cursor := Make_Temporary (Loc, 'I'); - declare + Default_Iter : constant Entity_Id := + Find_Aspect (Etype (Container), Aspect_Default_Iterator); Ent : Entity_Id; + begin + Cursor := Make_Temporary (Loc, 'I'); + + if Is_Iterator (Iter_Type) then + null; + + else + Iter_Type := + Etype + (Find_Aspect + (Etype (Container), Aspect_Default_Iterator)); + + -- Rewrite domain of iteration as a call to the default + -- iterator for the container type. + + Rewrite (Name (I_Spec), + Make_Function_Call (Loc, + Name => Default_Iter, + Parameter_Associations => + New_List (Relocate_Node (Name (I_Spec))))); + Analyze_And_Resolve (Name (I_Spec)); + end if; + + -- Find cursor type in container package. + Ent := First_Entity (Pack); while Present (Ent) loop if Chars (Ent) = Name_Cursor then @@ -2950,60 +2989,61 @@ package body Exp_Ch5 is end if; Next_Entity (Ent); end loop; + + -- Generate: + -- Id : Element_Type renames Pack.Element (Cursor); + + Decl := + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Id, + Subtype_Mark => + New_Reference_To (Element_Type, Loc), + Name => + Make_Indexed_Component (Loc, + Prefix => Make_Selected_Component (Loc, + Prefix => New_Reference_To (Pack, Loc), + Selector_Name => + Make_Identifier (Loc, Chars => Name_Element)), + Expressions => + New_List (New_Occurrence_Of (Cursor, Loc)))); + + -- If the container holds controlled objects, wrap the loop + -- statements and element renaming declaration with a block. + -- This ensures that the result of Element (Iterator) is + -- cleaned up after each iteration of the loop. + + if Needs_Finalization (Element_Type) then + + -- Generate: + -- declare + -- Id : Element_Type := Pack.Element (Iterator); + -- begin + -- <original loop statements> + -- end; + + Stats := New_List ( + Make_Block_Statement (Loc, + Declarations => New_List (Decl), + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stats))); + + -- Elements do not need finalization + + else + Prepend_To (Stats, Decl); + end if; end; + -- X in Iterate (S) : type of iterator is type of explicitly + -- given Iterate function. + else Cursor := Id; end if; Iterator := Make_Temporary (Loc, 'I'); - if Of_Present (I_Spec) then - - -- Generate: - -- Id : Element_Type renames Pack.Element (Cursor); - - Decl := - Make_Object_Renaming_Declaration (Loc, - Defining_Identifier => Id, - Subtype_Mark => - New_Reference_To (Element_Type, Loc), - Name => - Make_Indexed_Component (Loc, - Prefix => - Make_Selected_Component (Loc, - Prefix => - New_Reference_To (Pack, Loc), - Selector_Name => - Make_Identifier (Loc, Chars => Name_Element)), - Expressions => New_List ( - New_Occurrence_Of (Cursor, Loc)))); - - -- When the container holds controlled objects, wrap the loop - -- statements and element renaming declaration with a block. - -- This ensures that the transient result of Element (Iterator) - -- is cleaned up after each iteration of the loop. - - if Needs_Finalization (Element_Type) then - - -- Generate: - -- declare - -- Id : Element_Type := Pack.Element (Iterator); - -- begin - -- <original loop statements> - -- end; - - Stats := New_List ( - Make_Block_Statement (Loc, - Declarations => New_List (Decl), - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => Stats))); - else - Prepend_To (Stats, Decl); - end if; - end if; - -- Determine the advancement and initialization steps for the -- cursor. @@ -3026,23 +3066,16 @@ package body Exp_Ch5 is declare Rhs : Node_Id; + begin - if Of_Present (I_Spec) then - Rhs := - Make_Function_Call (Loc, - Name => Make_Identifier (Loc, Name_Step), - Parameter_Associations => - New_List (New_Reference_To (Cursor, Loc))); - else - Rhs := - Make_Function_Call (Loc, - Name => - Make_Selected_Component (Loc, - Prefix => New_Reference_To (Iterator, Loc), - Selector_Name => Make_Identifier (Loc, Name_Step)), - Parameter_Associations => New_List ( - New_Reference_To (Cursor, Loc))); - end if; + Rhs := + Make_Function_Call (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => New_Reference_To (Iterator, Loc), + Selector_Name => Make_Identifier (Loc, Name_Step)), + Parameter_Associations => New_List ( + New_Reference_To (Cursor, Loc))); Append_To (Stats, Make_Assignment_Statement (Loc, @@ -3082,14 +3115,13 @@ package body Exp_Ch5 is declare Decl1 : Node_Id; Decl2 : Node_Id; + begin Decl1 := Make_Object_Declaration (Loc, Defining_Identifier => Iterator, - Object_Definition => - New_Occurrence_Of (Etype (Name (I_Spec)), Loc), - - Expression => Relocate_Node (Name (I_Spec))); + Object_Definition => New_Occurrence_Of (Iter_Type, Loc), + Expression => Relocate_Node (Name (I_Spec))); Set_Assignment_OK (Decl1); Decl2 := diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 984bdb86989..34dfdd021e0 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -1535,9 +1535,7 @@ package body Exp_Ch7 is -- Generate: -- procedure Fin_Id is - -- Abort : constant Boolean := - -- Exception_Occurrence (Get_Current_Excep.all.all) = - -- Standard'Abort_Signal'Identity; + -- Abort : constant Boolean := Triggered_By_Abort; -- <or> -- Abort : constant Boolean := False; -- no abort @@ -3003,58 +3001,9 @@ package body Exp_Ch7 is and then VM_Target = No_VM and then not For_Package then - declare - Temp_Id : constant Entity_Id := Make_Temporary (Loc, 'E'); - - begin - -- Generate: - -- Temp : constant Exception_Occurrence_Access := - -- Get_Current_Excep.all; + A_Expr := New_Reference_To (RTE (RE_Triggered_By_Abort), Loc); - Append_To (Result, - Make_Object_Declaration (Loc, - Defining_Identifier => Temp_Id, - Constant_Present => True, - Object_Definition => - New_Reference_To (RTE (RE_Exception_Occurrence_Access), Loc), - Expression => - Make_Function_Call (Loc, - Name => - Make_Explicit_Dereference (Loc, - Prefix => - New_Reference_To - (RTE (RE_Get_Current_Excep), Loc))))); - - -- Generate: - -- Temp /= null - -- and then Exception_Identity (Temp.all) = - -- Standard'Abort_Signal'Identity; - - A_Expr := - Make_And_Then (Loc, - Left_Opnd => - Make_Op_Ne (Loc, - Left_Opnd => New_Reference_To (Temp_Id, Loc), - Right_Opnd => Make_Null (Loc)), - - Right_Opnd => - Make_Op_Eq (Loc, - Left_Opnd => - Make_Function_Call (Loc, - Name => - New_Reference_To (RTE (RE_Exception_Identity), Loc), - Parameter_Associations => New_List ( - Make_Explicit_Dereference (Loc, - Prefix => New_Reference_To (Temp_Id, Loc)))), - - Right_Opnd => - Make_Attribute_Reference (Loc, - Prefix => - New_Reference_To (Stand.Abort_Signal, Loc), - Attribute_Name => Name_Identity))); - end; - - -- No abort or .NET/JVM + -- No abort, .NET/JVM or library-level finalizers else A_Expr := New_Reference_To (Standard_False, Loc); @@ -3107,32 +3056,33 @@ package body Exp_Ch7 is Stmt : Node_Id; begin - -- Standard run-time, .NET/JVM targets - -- Call Raise_From_Controlled_Operation (E_Id). + -- Standard run-time and .NET/JVM targets use the specialized routine + -- Raise_From_Controlled_Operation. if RTE_Available (RE_Raise_From_Controlled_Operation) then Stmt := Make_Procedure_Call_Statement (Loc, - Name => - New_Reference_To (RTE (RE_Raise_From_Controlled_Operation), - Loc), + Name => + New_Reference_To + (RTE (RE_Raise_From_Controlled_Operation), Loc), Parameter_Associations => New_List (New_Reference_To (E_Id, Loc))); -- Restricted runtime: exception messages are not supported and hence - -- Raise_From_Controlled_Operation is not supported. - -- Simply raise Program_Error. + -- Raise_From_Controlled_Operation is not supported. Raise Program_Error + -- instead. else Stmt := Make_Raise_Program_Error (Loc, Reason => PE_Finalize_Raised_Exception); - end if; -- Generate: -- if Raised_Id and then not Abort_Id then -- Raise_From_Controlled_Operation (E_Id); + -- <or> + -- raise Program_Error; -- restricted runtime -- end if; return @@ -4717,12 +4667,7 @@ package body Exp_Ch7 is -- controlled elements. Generate: -- -- declare - -- Temp : constant Exception_Occurrence_Access := - -- Get_Current_Excep.all; - -- Abort : constant Boolean := - -- Temp /= null - -- and then Exception_Identity (Temp_Id.all) = - -- Standard'Abort_Signal'Identity; + -- Abort : constant Boolean := Triggered_By_Abort; -- <or> -- Abort : constant Boolean := False; -- no abort -- @@ -4773,12 +4718,7 @@ package body Exp_Ch7 is -- exception -- when others => -- declare - -- Temp : constant Exception_Occurrence_Access := - -- Get_Current_Excep.all; - -- Abort : constant Boolean := - -- Temp /= null - -- and then Exception_Identity (Temp_Id.all) = - -- Standard'Abort_Signal'Identity; + -- Abort : constant Boolean := Triggered_By_Abort; -- <or> -- Abort : constant Boolean := False; -- no abort -- E : Exception_Occurence; @@ -4970,9 +4910,7 @@ package body Exp_Ch7 is -- the conditional raise: -- declare - -- Abort : constant Boolean := - -- Exception_Occurrence (Get_Current_Excep.all.all) = - -- Standard'Abort_Signal'Identity; + -- Abort : constant Boolean := Triggered_By_Abort; -- <or> -- Abort : constant Boolean := False; -- no abort @@ -5257,9 +5195,7 @@ package body Exp_Ch7 is -- raised flag and the conditional raise. -- declare - -- Abort : constant Boolean := - -- Exception_Occurrence (Get_Current_Excep.all.all) = - -- Standard'Abort_Signal'Identity; + -- Abort : constant Boolean := Triggered_By_Abort; -- <or> -- Abort : constant Boolean := False; -- no abort @@ -5572,12 +5508,7 @@ package body Exp_Ch7 is -- may have discriminants and contain variant parts. Generate: -- -- declare - -- Temp : constant Exception_Occurrence_Access := - -- Get_Current_Excep.all; - -- Abort : constant Boolean := - -- Temp /= null - -- and then Exception_Identity (Temp_Id.all) = - -- Standard'Abort_Signal'Identity; + -- Abort : constant Boolean := Triggered_By_Abort; -- <or> -- Abort : constant Boolean := False; -- no abort -- E : Exception_Occurence; @@ -6049,9 +5980,7 @@ package body Exp_Ch7 is -- Generate: -- declare - -- Abort : constant Boolean := - -- Exception_Occurrence (Get_Current_Excep.all.all) = - -- Standard'Abort_Signal'Identity; + -- Abort : constant Boolean := Triggered_By_Abort; -- <or> -- Abort : constant Boolean := False; -- no abort @@ -6633,9 +6562,7 @@ package body Exp_Ch7 is -- Generate: -- declare - -- Abort : constant Boolean := - -- Exception_Occurrence (Get_Current_Excep.all.all) = - -- Standard'Abort_Signal'Identity; + -- Abort : constant Boolean := Triggered_By_Abort; -- <or> -- Abort : constant Boolean := False; -- no abort diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 1272d017268..603ea2b461d 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -2051,7 +2051,8 @@ package body Exp_Disp is -- F : out Boolean) -- is -- begin - -- null; + -- F := False; + -- C := Ada.Tags.POK_Function; -- end _Disp_Asynchronous_Select; -- For protected types, generate: @@ -2122,7 +2123,9 @@ package body Exp_Disp is New_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, - New_List (Make_Null_Statement (Loc)))); + New_List (Make_Assignment_Statement (Loc, + Name => Make_Identifier (Loc, Name_uF), + Expression => New_Reference_To (Standard_False, Loc))))); end if; if Is_Concurrent_Record_Type (Typ) then @@ -2262,6 +2265,14 @@ package body Exp_Disp is Expression => New_Reference_To (Com_Block, Loc)))); + -- Generate: + -- F := False; + + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => Make_Identifier (Loc, Name_uF), + Expression => New_Reference_To (Standard_False, Loc))); + else pragma Assert (Ekind (Conc_Typ) = E_Task_Type); @@ -2300,7 +2311,10 @@ package body Exp_Disp is else -- Ensure that the statements list is non-empty - Append_To (Stmts, Make_Null_Statement (Loc)); + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => Make_Identifier (Loc, Name_uF), + Expression => New_Reference_To (Standard_False, Loc))); end if; return @@ -2391,7 +2405,8 @@ package body Exp_Disp is -- F : out Boolean) -- is -- begin - -- null; + -- F := False; + -- C := Ada.Tags.POK_Function; -- end _Disp_Conditional_Select; -- For protected types, generate: @@ -2474,7 +2489,9 @@ package body Exp_Disp is No_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, - New_List (Make_Null_Statement (Loc)))); + New_List (Make_Assignment_Statement (Loc, + Name => Make_Identifier (Loc, Name_uF), + Expression => New_Reference_To (Standard_False, Loc))))); end if; if Is_Concurrent_Record_Type (Typ) then @@ -2675,9 +2692,16 @@ package body Exp_Disp is end if; else - -- Ensure that the statements list is non-empty + -- Initialize out parameters - Append_To (Stmts, Make_Null_Statement (Loc)); + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => Make_Identifier (Loc, Name_uF), + Expression => New_Reference_To (Standard_False, Loc))); + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => Make_Identifier (Loc, Name_uC), + Expression => New_Reference_To (RTE (RE_POK_Function), Loc))); end if; return @@ -3235,7 +3259,8 @@ package body Exp_Disp is -- F : out Boolean) -- is -- begin - -- null; + -- F := False; + -- C := Ada.Tags.POK_Function; -- end _Disp_Timed_Select; -- For protected types, generate: @@ -3294,7 +3319,7 @@ package body Exp_Disp is -- P, -- D, -- M, - -- D); + -- F); -- end _Disp_Time_Select; function Make_Disp_Timed_Select_Body @@ -3321,7 +3346,9 @@ package body Exp_Disp is New_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, - New_List (Make_Null_Statement (Loc)))); + New_List (Make_Assignment_Statement (Loc, + Name => Make_Identifier (Loc, Name_uF), + Expression => New_Reference_To (Standard_False, Loc))))); end if; if Is_Concurrent_Record_Type (Typ) then @@ -3500,9 +3527,16 @@ package body Exp_Disp is end if; else - -- Ensure that the statements list is non-empty + -- Initialize out parameters - Append_To (Stmts, Make_Null_Statement (Loc)); + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => Make_Identifier (Loc, Name_uF), + Expression => New_Reference_To (Standard_False, Loc))); + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => Make_Identifier (Loc, Name_uC), + Expression => New_Reference_To (RTE (RE_POK_Function), Loc))); end if; return diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb index 642de80755f..aba013d85ae 100644 --- a/gcc/ada/par-ch3.adb +++ b/gcc/ada/par-ch3.adb @@ -1083,7 +1083,11 @@ package body Ch3 is begin Constr_Node := P_Constraint_Opt; - if No (Constr_Node) then + if No (Constr_Node) + or else + (Nkind (Constr_Node) = N_Range_Constraint + and then Nkind (Range_Expression (Constr_Node)) = N_Error) + then return Subtype_Mark; else if Not_Null_Present then @@ -2668,9 +2672,11 @@ package body Ch3 is Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); end if; - if Aliased_Present then - Error_Msg_SP ("ALIASED not allowed here"); - end if; + -- AI95-406 makes "aliased" legal (and useless) in this context. + + -- if Aliased_Present then + -- Error_Msg_SP ("ALIASED not allowed here"); + -- end if; Set_Subtype_Indication (CompDef_Node, Empty); Set_Aliased_Present (CompDef_Node, False); @@ -3443,9 +3449,11 @@ package body Ch3 is Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); end if; - if Aliased_Present then - Error_Msg_SP ("ALIASED not allowed here"); - end if; + -- AI95-406 makes "aliased" legal (and useless) here. + + -- if Aliased_Present then + -- Error_Msg_SP ("ALIASED not allowed here"); + -- end if; Set_Subtype_Indication (CompDef_Node, Empty); Set_Aliased_Present (CompDef_Node, False); diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index b4f350a3bc4..d262e86cae1 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -520,6 +520,7 @@ package Rtsfind is RE_Reraise_Occurrence_Always, -- Ada.Exceptions RE_Reraise_Occurrence_No_Defer, -- Ada.Exceptions RE_Save_Occurrence, -- Ada.Exceptions + RE_Triggered_By_Abort, -- Ada.Exceptions RE_Interrupt_ID, -- Ada.Interrupts RE_Is_Reserved, -- Ada.Interrupts @@ -1707,6 +1708,7 @@ package Rtsfind is RE_Reraise_Occurrence_Always => Ada_Exceptions, RE_Reraise_Occurrence_No_Defer => Ada_Exceptions, RE_Save_Occurrence => Ada_Exceptions, + RE_Triggered_By_Abort => Ada_Exceptions, RE_Interrupt_ID => Ada_Interrupts, RE_Is_Reserved => Ada_Interrupts, diff --git a/gcc/ada/s-stposu.adb b/gcc/ada/s-stposu.adb index 0cdc90b7084..9a6c2310996 100644 --- a/gcc/ada/s-stposu.adb +++ b/gcc/ada/s-stposu.adb @@ -39,6 +39,11 @@ with System.Storage_Elements; use System.Storage_Elements; package body System.Storage_Pools.Subpools is + Finalize_Address_Table_In_Use : Boolean := False; + -- This flag should be set only when a successfull allocation on a subpool + -- has been performed and the associated Finalize_Address has been added to + -- the hash table in System.Finalization_Masters. + procedure Attach (N : not null SP_Node_Ptr; L : not null SP_Node_Ptr); -- Attach a subpool node to a pool @@ -269,6 +274,7 @@ package body System.Storage_Pools.Subpools is pragma Assert (not Master.Is_Homogeneous); Set_Finalize_Address (Addr, Fin_Address); + Finalize_Address_Table_In_Use := True; -- Normal allocations chain objects on homogeneous collections @@ -335,12 +341,11 @@ package body System.Storage_Pools.Subpools is if Is_Controlled then -- Destroy the relation pair object - Finalize_Address since it is no - -- longer needed. If the object was chained on a homogeneous master, - -- this call does nothing. This is unconditional destruction since we - -- do not want to drag in additional data to determine the master - -- kind. + -- longer needed. - Delete_Finalize_Address (Addr); + if Finalize_Address_Table_In_Use then + Delete_Finalize_Address (Addr); + end if; -- Account for possible padding space before the header due to a -- larger alignment. diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 8df2d05fbf8..873e13baf61 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -2573,7 +2573,11 @@ package body Sem_Ch12 is end; if Subp /= Any_Id then + + -- Subprogram found, generate reference to it. + Set_Entity (Def, Subp); + Generate_Reference (Subp, Def); if Subp = Nam then Error_Msg_N ("premature usage of formal subprogram", Def); diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index ef74ed9df03..5ac99e87790 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -2342,42 +2342,17 @@ package body Sem_Ch5 is Set_Ekind (Def_Id, E_Loop_Parameter); if Of_Present (N) then - -- If the container has already been rewritten as a - -- call to the default iterator, nothing to do. This - -- is the case with the expansion of a quantified - -- expression. - if Nkind (Name (N)) = N_Function_Call - and then not Comes_From_Source (Name (N)) - then - null; - - elsif Expander_Active then - - -- Find the Iterator_Element and the default_iterator - -- of the container type. - - Set_Etype (Def_Id, - Entity ( - Find_Aspect (Typ, Aspect_Iterator_Element))); + -- The type of the loop variable is the Iterator_Element + -- aspect of the container type. - declare - Default_Iter : constant Entity_Id := - Find_Aspect (Typ, Aspect_Default_Iterator); - begin - Rewrite (Name (N), - Make_Function_Call (Loc, - Name => Default_Iter, - Parameter_Associations => - New_List (Relocate_Node (Iter_Name)))); - Analyze_And_Resolve (Name (N)); - end; - end if; + Set_Etype (Def_Id, + Entity (Find_Aspect (Typ, Aspect_Iterator_Element))); else - -- result type of Iterate function is the classwide - -- type of the interface parent. We need the specific - -- Cursor type defined in the package. + -- The result type of Iterate function is the classwide type + -- of the interface parent. We need the specific Cursor type + -- defined in the container package. Ent := First_Entity (Scope (Typ)); while Present (Ent) loop diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 47632f304c9..5a782f3c20c 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -721,6 +721,12 @@ package body Sem_Ch8 is then null; + -- A renaming of an unchecked union does not have an + -- actual subtype. + + elsif Is_Unchecked_Union (Etype (Nam)) then + null; + else Subt := Make_Temporary (Loc, 'T'); Remove_Side_Effects (Nam); diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 433678a81b9..15c96c6ba2a 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -4382,8 +4382,8 @@ package body Sem_Res is end if; -- Report a simple error: if the designated object is a local task, - -- its body has not been seen yet, and its activation will fail - -- an elaboration check. + -- its body has not been seen yet, and its activation will fail an + -- elaboration check. if Is_Task_Type (Desig_T) and then Scope (Base_Type (Desig_T)) = Current_Scope @@ -4391,10 +4391,21 @@ package body Sem_Res is and then Ekind (Current_Scope) = E_Package and then not In_Package_Body (Current_Scope) then - Error_Msg_N - ("cannot activate task before body seen?", N); + Error_Msg_N ("cannot activate task before body seen?", N); Error_Msg_N ("\Program_Error will be raised at run time?", N); end if; + + -- Ada 2012 (AI05-0111-3): Issue a warning whenever allocating a task + -- or a type containing tasks on a subpool since the deallocation of + -- the subpool may lead to undefined task behavior. + + if Ada_Version >= Ada_2012 + and then Present (Subpool_Handle_Name (N)) + and then Has_Task (Desig_T) + then + Error_Msg_N ("?allocation of task on subpool may lead to " & + "undefined behavior", N); + end if; end Resolve_Allocator; --------------------------- diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 2b40b63baf3..e855da24ef4 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -7175,7 +7175,19 @@ package body Sem_Util is Iface : Entity_Id; begin - if not Is_Tagged_Type (Typ) or else not Is_Derived_Type (Typ) then + if Is_Class_Wide_Type (Typ) + and then + (Chars (Etype (Typ)) = Name_Forward_Iterator + or else Chars (Etype (Typ)) = Name_Reversible_Iterator) + and then + Is_Predefined_File_Name + (Unit_File_Name (Get_Source_Unit (Etype (Typ)))) + then + return True; + + elsif not Is_Tagged_Type (Typ) + or else not Is_Derived_Type (Typ) + then return False; else @@ -7198,6 +7210,51 @@ package body Sem_Util is return False; end if; end Is_Iterator; + + ---------------------------- + -- Is_Reversible_Iterator -- + ---------------------------- + + function Is_Reversible_Iterator (Typ : Entity_Id) return Boolean is + Ifaces_List : Elist_Id; + Iface_Elmt : Elmt_Id; + Iface : Entity_Id; + + begin + if Is_Class_Wide_Type (Typ) + and then Chars (Etype (Typ)) = Name_Reversible_Iterator + and then + Is_Predefined_File_Name + (Unit_File_Name (Get_Source_Unit (Etype (Typ)))) + then + return True; + + elsif not Is_Tagged_Type (Typ) + or else not Is_Derived_Type (Typ) + then + return False; + else + + Collect_Interfaces (Typ, Ifaces_List); + + Iface_Elmt := First_Elmt (Ifaces_List); + while Present (Iface_Elmt) loop + Iface := Node (Iface_Elmt); + if Chars (Iface) = Name_Reversible_Iterator + and then + Is_Predefined_File_Name + (Unit_File_Name (Get_Source_Unit (Iface))) + then + return True; + end if; + + Next_Elmt (Iface_Elmt); + end loop; + + end if; + return False; + end Is_Reversible_Iterator; + ------------ -- Is_LHS -- ------------ @@ -7841,40 +7898,6 @@ package body Sem_Util is return False; end Is_Renamed_Entry; - ---------------------------- - -- Is_Reversible_Iterator -- - ---------------------------- - - function Is_Reversible_Iterator (Typ : Entity_Id) return Boolean is - Ifaces_List : Elist_Id; - Iface_Elmt : Elmt_Id; - Iface : Entity_Id; - - begin - if not Is_Tagged_Type (Typ) or else not Is_Derived_Type (Typ) then - return False; - - else - Collect_Interfaces (Typ, Ifaces_List); - - Iface_Elmt := First_Elmt (Ifaces_List); - while Present (Iface_Elmt) loop - Iface := Node (Iface_Elmt); - if Chars (Iface) = Name_Reversible_Iterator - and then - Is_Predefined_File_Name - (Unit_File_Name (Get_Source_Unit (Iface))) - then - return True; - end if; - - Next_Elmt (Iface_Elmt); - end loop; - end if; - - return False; - end Is_Reversible_Iterator; - ---------------------- -- Is_Selector_Name -- ---------------------- |