diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 0321d69127a9..62df17c5acd5 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,51 @@ +2011-08-04 Hristian Kirtchev + + * exp_ch7.adb (Build_Raise_Statement): Remove the specialized + processing for .NET/JVM. These targets can now benefit from + Raise_From_Controlled_Operation and they share the same processing with + standard targets. + (Establish_Transient_Scope): Remove the restriction for .NET/JVM. + These targets need transient scopes in order to properly finalize short + lived controlled objects. + (Make_Handler_For_Ctrl_Operation): Remove the specialized processing for + NET/JVM. These targets can now benefit from + Raise_From_Controlled_Operation and they share the same processing with + standard targets. + +2011-08-04 Geert Bosch + + * tracebak.c (STOP_FRAME): Stop at any next pointer outside the stack + +2011-08-04 Ed Schonberg + + * exp_aggr.adb (Has_Visible_Private_Ancestor): subsidiary routine to + Expand_Record_Aggregate, to determine whether aggregate must be + expanded into assignments. This is the case if the ancestor part is + private, regarless of the setting of the flag Has_Private_Ancestor. + +2011-08-04 Ed Falis + + * vxaddr2line.adb: Add support for e500v2 and for Linux hosts + +2011-08-04 Bob Duff + + * sinfo.ads: Fix comment. + +2011-08-04 Steve Baird + + * bindgen.adb (Get_Ada_Main_Name): If CodePeer_Mode is set, then + choose a package name in much the same way as is + done for JGNAT when VM_Target /= No_VM, except that + a slightly more distinctive prefix string is used. + +2011-08-04 Emmanuel Briot + + * makeutl.adb (Complete_Mains): no longer accept unit names on the + gnatmake command line. + This behavior was never documented (and was supported only because of + an early bug in the code). This case might lead to ambiguous cases + (between unit names and truncated base names without suffixes). + 2011-08-04 Hristian Kirtchev * a-tags.ads, a-tags.adb (Unregister_Tag): New routine. diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index 3f88f66f9ab4..7ee751168797 100644 --- a/gcc/ada/bindgen.adb +++ b/gcc/ada/bindgen.adb @@ -3783,12 +3783,21 @@ package body Bindgen is begin -- The main program generated by JGNAT expects a package called -- ada_
. - if VM_Target /= No_VM then Get_Name_String (Units.Table (First_Unit_Entry).Uname); return "ada_" & Get_Main_Unit_Name (Name_Buffer (1 .. Name_Len - 2)); end if; + -- For CodePeer, we want reproducible names (independent of other + -- mains that may or may not be present) that don't collide + -- when analyzing multiple mains and which are easily recognizable + -- as "ada_main" names. + if CodePeer_Mode then + Get_Name_String (Units.Table (First_Unit_Entry).Uname); + return "ada_main_for_" & + Get_Main_Unit_Name (Name_Buffer (1 .. Name_Len - 2)); + end if; + -- This loop tries the following possibilities in order -- -- _01 diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index a38eb597f088..d6b53d442f6c 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -5178,6 +5178,33 @@ package body Exp_Aggr is Comp : Entity_Id; New_Comp : Node_Id; + function Has_Visible_Private_Ancestor (Id : E) return Boolean; + -- If any ancestor of the current type is private, the aggregate + -- cannot be built in place. We canot rely on Has_Private_Ancestor, + -- because it will not be set when type and its parent are in the + -- same scope, and the parent component needs expansion. + + ----------------------------------- + -- Has_Visible_Private_Ancestor -- + ----------------------------------- + + function Has_Visible_Private_Ancestor (Id : E) return Boolean is + R : constant Entity_Id := Root_Type (Id); + T1 : Entity_Id := Id; + begin + loop + if Is_Private_Type (T1) then + return True; + + elsif T1 = R then + return False; + + else + T1 := Etype (T1); + end if; + end loop; + end Has_Visible_Private_Ancestor; + -- Start of processing for Expand_Record_Aggregate begin @@ -5261,7 +5288,7 @@ package body Exp_Aggr is -- If an ancestor is private, some components are not inherited and -- we cannot expand into a record aggregate - elsif Has_Private_Ancestor (Typ) then + elsif Has_Visible_Private_Ancestor (Typ) then Convert_To_Assignments (N, Typ); -- ??? The following was done to compile fxacc00.ads in the ACVCs. Gigi diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 678948ad879b..a679c294c893 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -3064,15 +3064,10 @@ package body Exp_Ch7 is Params := New_List (New_Reference_To (E_Id, Loc)); - -- .NET/JVM + -- Standard run-time, .NET/JVM targets, this case handles finalization + -- exceptions raised during an abort. - if VM_Target /= No_VM then - Proc_Id := RTE (RE_Reraise_Occurrence); - - -- Standard run-time library, this case handles finalization exceptions - -- raised during an abort. - - elsif RTE_Available (RE_Raise_From_Controlled_Operation) then + if RTE_Available (RE_Raise_From_Controlled_Operation) then Proc_Id := RTE (RE_Raise_From_Controlled_Operation); Append_To (Params, New_Reference_To (Abort_Id, Loc)); @@ -3494,12 +3489,6 @@ package body Exp_Ch7 is Wrap_Node : Node_Id; begin - -- Nothing to do for virtual machines where memory is GCed - - if VM_Target /= No_VM then - return; - end if; - -- Do not create a transient scope if we are already inside one for S in reverse Scope_Stack.First .. Scope_Stack.Last loop @@ -3515,7 +3504,6 @@ package body Exp_Ch7 is elsif Scope_Stack.Table (S).Entity = Standard_Standard then exit; - end if; end loop; @@ -7228,23 +7216,12 @@ package body Exp_Ch7 is -- Procedure call or raise statement begin - -- .NET/JVM runtime: add choice parameter E and pass it to Reraise_ - -- Occurrence. + -- Standard runtime, .NET/JVM targets: add choice parameter E and pass + -- it to Raise_From_Controlled_Operation so that the original exception + -- name and message can be recorded in the exception message for + -- Program_Error. - if VM_Target /= No_VM then - E_Occ := Make_Defining_Identifier (Loc, Name_E); - Raise_Node := - Make_Procedure_Call_Statement (Loc, - Name => - New_Reference_To (RTE (RE_Reraise_Occurrence), Loc), - Parameter_Associations => New_List ( - New_Reference_To (E_Occ, Loc))); - - -- Standard runtime: add choice parameter E and pass it to Raise_From_ - -- Controlled_Operation so that the original exception name and message - -- can be recorded in the exception message for Program_Error. - - elsif RTE_Available (RE_Raise_From_Controlled_Operation) then + if RTE_Available (RE_Raise_From_Controlled_Operation) then E_Occ := Make_Defining_Identifier (Loc, Name_E); Raise_Node := Make_Procedure_Call_Statement (Loc, diff --git a/gcc/ada/makeutl.adb b/gcc/ada/makeutl.adb index 87eeec8090c0..b51e7fb297fa 100644 --- a/gcc/ada/makeutl.adb +++ b/gcc/ada/makeutl.adb @@ -1290,7 +1290,6 @@ package body Makeutl is function Find_File_Add_Extension (Tree : Project_Tree_Ref; - Root_Project : Project_Id; Base_Main : String) return Prj.Source_Id; -- Search for Main in the project, adding body or spec extensions. @@ -1346,66 +1345,57 @@ package body Makeutl is function Find_File_Add_Extension (Tree : Project_Tree_Ref; - Root_Project : Project_Id; Base_Main : String) return Prj.Source_Id is Spec_Source : Prj.Source_Id := No_Source; Source : Prj.Source_Id; - Project : Project_Id; Iter : Source_Iterator; Suffix : File_Name_Type; begin Source := No_Source; - Project := Root_Project; - while Source = No_Source - and then Project /= No_Project + Iter := For_Each_Source (Tree); -- In all projects loop - Iter := For_Each_Source (Tree, Project); - loop - Source := Prj.Element (Iter); - exit when Source = No_Source; + Source := Prj.Element (Iter); + exit when Source = No_Source; - if Source.Kind = Impl then - Get_Name_String (Source.File); + if Source.Kind = Impl then + Get_Name_String (Source.File); - if Name_Len > Base_Main'Length - and then Name_Buffer (1 .. Base_Main'Length) = Base_Main - then - Suffix := - Source.Language.Config.Naming_Data.Body_Suffix; + if Name_Len > Base_Main'Length + and then Name_Buffer (1 .. Base_Main'Length) = Base_Main + then + Suffix := + Source.Language.Config.Naming_Data.Body_Suffix; - exit when Suffix /= No_File and then - Name_Buffer (Base_Main'Length + 1 .. Name_Len) = - Get_Name_String (Suffix); - end if; - - elsif Source.Kind = Spec then - -- A spec needs to be taken into account unless there is - -- also a body. So we delay the decision for them. - - Get_Name_String (Source.File); - - if Name_Len > Base_Main'Length - and then Name_Buffer (1 .. Base_Main'Length) = Base_Main - then - Suffix := - Source.Language.Config.Naming_Data.Spec_Suffix; - - if Suffix /= No_File - and then - Name_Buffer (Base_Main'Length + 1 .. Name_Len) = - Get_Name_String (Suffix) - then - Spec_Source := Source; - end if; - end if; + exit when Suffix /= No_File and then + Name_Buffer (Base_Main'Length + 1 .. Name_Len) = + Get_Name_String (Suffix); end if; - Next (Iter); - end loop; + elsif Source.Kind = Spec then + -- A spec needs to be taken into account unless there is + -- also a body. So we delay the decision for them. - Project := Project.Extends; + Get_Name_String (Source.File); + + if Name_Len > Base_Main'Length + and then Name_Buffer (1 .. Base_Main'Length) = Base_Main + then + Suffix := + Source.Language.Config.Naming_Data.Spec_Suffix; + + if Suffix /= No_File + and then + Name_Buffer (Base_Main'Length + 1 .. Name_Len) = + Get_Name_String (Suffix) + then + Spec_Source := Source; + end if; + end if; + end if; + + Next (Iter); end loop; if Source = No_Source then @@ -1496,7 +1486,7 @@ package body Makeutl is if Source = No_Source then Source := Find_File_Add_Extension - (Tree, File.Project, Get_Name_String (Main_Id)); + (Tree, Get_Name_String (Main_Id)); end if; if Is_Absolute @@ -1510,29 +1500,6 @@ package body Makeutl is Source := No_Source; end if; - if Source = No_Source - and then not Is_Absolute - then - - -- Still not found? Maybe we have a unit name - - declare - Unit : constant Unit_Index := - Units_Htable.Get - (File.Tree.Units_HT, - Name_Id (Main_Id)); - - begin - if Unit /= No_Unit_Index then - Source := Unit.File_Names (Impl); - - if Source = No_Source then - Source := Unit.File_Names (Spec); - end if; - end if; - end; - end if; - if Source /= No_Source then -- If we have found a multi-unit source file but @@ -2988,6 +2955,22 @@ package body Makeutl is Shared => Project_Tree.Shared, Force_Lower_Case_Index => False, Allow_Wildcards => True); + + -- If not found, try without extension. + -- That's because gnatmake accepts truncated file names + -- in Builder'Switches + + if Switches_For_Main = Nil_Variable_Value + and then Source.Unit /= null + then + Switches_For_Main := Value_Of + (Name => Source.Unit.Name, + Attribute_Or_Array_Name => Name_Switches, + In_Package => Builder_Package, + Shared => Project_Tree.Shared, + Force_Lower_Case_Index => False, + Allow_Wildcards => True); + end if; end if; if Index = 1 then diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 1fdaae8a9fdc..a7134754a6eb 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -5894,23 +5894,32 @@ package Sinfo is -- used only internally currently, but is considered to be syntactic. -- At the moment, the only cleanup action allowed is a single call to -- a parameterless procedure, and the Identifier field of the node is - -- the procedure to be called. Also there is a current restriction - -- that exception handles and a cleanup cannot be present in the same - -- frame, so at least one of Exception_Handlers or the Identifier must - -- be missing. + -- the procedure to be called. The cleanup action occurs whenever the + -- sequence of statements is left for any reason. The possible reasons + -- are: + -- 1. reaching the end of the sequence + -- 2. exit, return, or goto + -- 3. exception or abort + -- For some back ends, such as gcc with ZCX, "at end" is implemented + -- entirely in the back end. In this case, a handled sequence of + -- statements with an "at end" cannot also have exception handlers. + -- For other back ends, such as gcc with SJLJ and .NET, the + -- implementation is split between the front end and back end; the front + -- end implements 3, and the back end implements 1 and 2. In this case, + -- if there is an "at end", the front end inserts the appropriate + -- exception handler, and this handler takes precedence over "at end" + -- in case of exception. - -- Actually, more accurately, this restriction applies to the original - -- source program. In the expanded tree, if the At_End_Proc field is - -- present, then there will also be an exception handler of the form: + -- The inserted exception handler is of the form: -- when all others => -- cleanup; -- raise; - -- where cleanup is the procedure to be generated. The reason we do - -- this is so that the front end can handle the necessary entries in - -- the exception tables, and other exception handler actions required - -- as part of the normal handling for exception handlers. + -- where cleanup is the procedure to be called. The reason we do this is + -- so that the front end can handle the necessary entries in the + -- exception tables, and other exception handler actions required as + -- part of the normal handling for exception handlers. -- The AT END cleanup handler protects only the sequence of statements -- (not the associated declarations of the parent), just like exception diff --git a/gcc/ada/tracebak.c b/gcc/ada/tracebak.c index 2e292857e617..eedc715a2e5f 100644 --- a/gcc/ada/tracebak.c +++ b/gcc/ada/tracebak.c @@ -339,7 +339,8 @@ struct layout #define STOP_FRAME(CURRENT, TOP_STACK) \ (IS_BAD_PTR((long)(CURRENT)) \ || IS_BAD_PTR((long)(CURRENT)->return_address) \ - || (CURRENT)->return_address == 0|| (CURRENT)->next == 0 \ + || (CURRENT)->return_address == 0 \ + || (void *) ((CURRENT)->next) < (TOP_STACK) \ || (void *) (CURRENT) < (TOP_STACK)) #define BASE_SKIP (1+FRAME_LEVEL) diff --git a/gcc/ada/vxaddr2line.adb b/gcc/ada/vxaddr2line.adb index f1bb48a74289..028de5e5fbf4 100644 --- a/gcc/ada/vxaddr2line.adb +++ b/gcc/ada/vxaddr2line.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2002-2009, AdaCore -- +-- Copyright (C) 2002-2011, AdaCore -- -- -- -- 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- -- @@ -83,12 +83,17 @@ procedure VxAddr2Line is -- All supported architectures type Architecture is - (SOLARIS_I586, - WINDOWS_POWERPC, + (DEC_ALPHA, + LINUX_E500V2, + LINUX_I586, + LINUX_POWERPC, + WINDOWS_E500V2, WINDOWS_I586, WINDOWS_M68K, - SOLARIS_POWERPC, - DEC_ALPHA); + WINDOWS_POWERPC, + SOLARIS_E500V2, + SOLARIS_I586, + SOLARIS_POWERPC); type Arch_Record is record Addr2line_Binary : String_Access; @@ -114,12 +119,42 @@ procedure VxAddr2Line is -- Configuration for each of the architectures Arch_List : array (Architecture'Range) of Arch_Record := - (WINDOWS_POWERPC => + (DEC_ALPHA => + (Addr2line_Binary => null, + Nm_Binary => null, + Addr_Digits_To_Skip => 8, + Bt_Offset_From_Call => 0), + LINUX_E500V2 => (Addr2line_Binary => null, Nm_Binary => null, Addr_Digits_To_Skip => 0, Bt_Offset_From_Call => -4), - WINDOWS_M68K => + LINUX_I586 => + (Addr2line_Binary => null, + Nm_Binary => null, + Addr_Digits_To_Skip => 0, + Bt_Offset_From_Call => -2), + LINUX_POWERPC => + (Addr2line_Binary => null, + Nm_Binary => null, + Addr_Digits_To_Skip => 0, + Bt_Offset_From_Call => -4), + SOLARIS_E500V2 => + (Addr2line_Binary => null, + Nm_Binary => null, + Addr_Digits_To_Skip => 0, + Bt_Offset_From_Call => -4), + SOLARIS_I586 => + (Addr2line_Binary => null, + Nm_Binary => null, + Addr_Digits_To_Skip => 0, + Bt_Offset_From_Call => -2), + SOLARIS_POWERPC => + (Addr2line_Binary => null, + Nm_Binary => null, + Addr_Digits_To_Skip => 0, + Bt_Offset_From_Call => -4), + WINDOWS_E500V2 => (Addr2line_Binary => null, Nm_Binary => null, Addr_Digits_To_Skip => 0, @@ -129,21 +164,16 @@ procedure VxAddr2Line is Nm_Binary => null, Addr_Digits_To_Skip => 0, Bt_Offset_From_Call => -2), - SOLARIS_POWERPC => + WINDOWS_M68K => (Addr2line_Binary => null, Nm_Binary => null, Addr_Digits_To_Skip => 0, - Bt_Offset_From_Call => 0), - SOLARIS_I586 => + Bt_Offset_From_Call => -4), + WINDOWS_POWERPC => (Addr2line_Binary => null, Nm_Binary => null, Addr_Digits_To_Skip => 0, - Bt_Offset_From_Call => -2), - DEC_ALPHA => - (Addr2line_Binary => null, - Nm_Binary => null, - Addr_Digits_To_Skip => 8, - Bt_Offset_From_Call => 0) + Bt_Offset_From_Call => -4) ); -- Current architecture