From 7ae0d98c02dda4cbf0d3c9cac19a7358f8b53071 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Thu, 4 Aug 2011 15:20:09 +0200 Subject: [PATCH] [multiple changes] 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). From-SVN: r177379 --- gcc/ada/ChangeLog | 48 +++++++++++++++++ gcc/ada/bindgen.adb | 11 +++- gcc/ada/exp_aggr.adb | 29 ++++++++++- gcc/ada/exp_ch7.adb | 39 +++----------- gcc/ada/makeutl.adb | 113 +++++++++++++++++----------------------- gcc/ada/sinfo.ads | 33 +++++++----- gcc/ada/tracebak.c | 3 +- gcc/ada/vxaddr2line.adb | 56 +++++++++++++++----- 8 files changed, 208 insertions(+), 124 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 0321d69127a..62df17c5acd 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 3f88f66f9ab..7ee75116879 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 a38eb597f08..d6b53d442f6 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 678948ad879..a679c294c89 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. - - 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. + -- 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. - 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 87eeec8090c..b51e7fb297f 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; + 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. + 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); + 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 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; + 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; - - Project := Project.Extends; + 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 1fdaae8a9fd..a7134754a6e 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. - - -- 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 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. + + -- 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 2e292857e61..eedc715a2e5 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 f1bb48a7428..028de5e5fbf 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,17 +119,32 @@ 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), - WINDOWS_I586 => + 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, @@ -133,17 +153,27 @@ procedure VxAddr2Line is (Addr2line_Binary => null, Nm_Binary => null, Addr_Digits_To_Skip => 0, - Bt_Offset_From_Call => 0), - SOLARIS_I586 => + Bt_Offset_From_Call => -4), + WINDOWS_E500V2 => + (Addr2line_Binary => null, + Nm_Binary => null, + Addr_Digits_To_Skip => 0, + Bt_Offset_From_Call => -4), + WINDOWS_I586 => (Addr2line_Binary => null, Nm_Binary => null, Addr_Digits_To_Skip => 0, Bt_Offset_From_Call => -2), - DEC_ALPHA => + WINDOWS_M68K => (Addr2line_Binary => null, Nm_Binary => null, - Addr_Digits_To_Skip => 8, - Bt_Offset_From_Call => 0) + Addr_Digits_To_Skip => 0, + Bt_Offset_From_Call => -4), + WINDOWS_POWERPC => + (Addr2line_Binary => null, + Nm_Binary => null, + Addr_Digits_To_Skip => 0, + Bt_Offset_From_Call => -4) ); -- Current architecture -- 2.30.2