From 229c2354d5315ae45932c64ce51fa35e7ad3436a Mon Sep 17 00:00:00 2001 From: charlet Date: Fri, 2 Sep 2011 09:47:42 +0000 Subject: [PATCH] 2011-09-02 Robert Dewar * exp_ch4.adb, exp_ch6.adb, prj-nmsc.adb: Minor reformatting. 2011-09-02 Hristian Kirtchev * exp_util.adb (Extract_Renamed_Object): Renamed to Find_Renamed_Object. This routine has been reimplemented and now uses tree traversal to locate a renamed object. (Is_Aliased): Replace call to Extract_Renamed_Object with Find_Renamed_Object. 2011-09-02 Tristan Gingold * init.c: (__gnat_is_vms_v7): New function. 2011-09-02 Olivier Hainque * tracebak.c (STOP_FRAME, ppc elf/vxworks case): Stop on frames that have a misaligned backchain, necessarily bogus. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@178457 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/ChangeLog | 21 +++++++++++++++ gcc/ada/exp_ch4.adb | 6 ++--- gcc/ada/exp_ch6.adb | 4 +-- gcc/ada/exp_util.adb | 76 ++++++++++++++++++++++++++++++---------------------- gcc/ada/init.c | 23 ++++++++++++++++ gcc/ada/prj-nmsc.adb | 20 +++++++------- gcc/ada/tracebak.c | 8 +++++- 7 files changed, 111 insertions(+), 47 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 98abf03..1f8cebf 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,24 @@ +2011-09-02 Robert Dewar + + * exp_ch4.adb, exp_ch6.adb, prj-nmsc.adb: Minor reformatting. + +2011-09-02 Hristian Kirtchev + + * exp_util.adb (Extract_Renamed_Object): Renamed to + Find_Renamed_Object. This routine has been reimplemented and now uses + tree traversal to locate a renamed object. + (Is_Aliased): Replace call to Extract_Renamed_Object with + Find_Renamed_Object. + +2011-09-02 Tristan Gingold + + * init.c: (__gnat_is_vms_v7): New function. + +2011-09-02 Olivier Hainque + + * tracebak.c (STOP_FRAME, ppc elf/vxworks case): Stop on frames + that have a misaligned backchain, necessarily bogus. + 2011-09-02 Hristian Kirtchev * exp_ch3.adb (Expand_Freeze_Class_Wide_Type): Do not create diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 4e652eb..f3f20fc 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -1150,13 +1150,13 @@ package body Exp_Ch4 is -- Set_Finalize_Address (FM, FD'Unrestricted_Access); -- Do not generate this call in the following cases: - -- + -- * .NET/JVM - these targets do not support address arithmetic -- and unchecked conversion, key elements of Finalize_Address. - -- + -- * Alfa mode - the call is useless and results in unwanted -- expansion. - -- + -- * CodePeer mode - TSS primitive Finalize_Address is not -- created in this mode. diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index fd85a03..3ff42b6 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -6519,8 +6519,8 @@ package body Exp_Ch6 is begin -- Ada 2005 (AI-251): In class-wide interface objects we displace - -- "this" to reference the base of the object required to get - -- access to the TSD of the object. + -- "this" to reference the base of the object. This is required to + -- get access to the TSD of the object. if Is_Class_Wide_Type (Etype (Exp)) and then Is_Interface (Etype (Exp)) diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 022f5f6..34901ab 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -3887,49 +3887,61 @@ package body Exp_Util is (Trans_Id : Entity_Id; First_Stmt : Node_Id) return Boolean is - function Extract_Renamed_Object - (Ren_Decl : Node_Id) return Entity_Id; + function Find_Renamed_Object (Ren_Decl : Node_Id) return Entity_Id; -- Given an object renaming declaration, retrieve the entity of the -- renamed name. Return Empty if the renamed name is anything other -- than a variable or a constant. - ---------------------------- - -- Extract_Renamed_Object -- - ---------------------------- + ------------------------- + -- Find_Renamed_Object -- + ------------------------- - function Extract_Renamed_Object - (Ren_Decl : Node_Id) return Entity_Id - is - Change : Boolean; - Ren_Obj : Node_Id; + function Find_Renamed_Object (Ren_Decl : Node_Id) return Entity_Id is + Ren_Obj : Node_Id := Empty; - begin - Change := True; - Ren_Obj := Renamed_Object (Defining_Identifier (Ren_Decl)); - while Change loop - Change := False; - - if Nkind_In (Ren_Obj, N_Explicit_Dereference, - N_Indexed_Component, - N_Selected_Component) - then - Ren_Obj := Prefix (Ren_Obj); - Change := True; + function Find_Object (N : Node_Id) return Traverse_Result; + -- Try to detect an object which is either a constant or a + -- variable. - elsif Nkind_In (Ren_Obj, N_Type_Conversion, - N_Unchecked_Type_Conversion) + ----------------- + -- Find_Object -- + ----------------- + + function Find_Object (N : Node_Id) return Traverse_Result is + begin + -- Stop the search once a constant or a variable has been + -- detected. + + if Nkind (N) = N_Identifier + and then Present (Entity (N)) + and then Ekind_In (Entity (N), E_Constant, E_Variable) then - Ren_Obj := Expression (Ren_Obj); - Change := True; + Ren_Obj := Entity (N); + return Abandon; end if; - end loop; - if Nkind (Ren_Obj) in N_Has_Entity then - return Entity (Ren_Obj); + return OK; + end Find_Object; + + procedure Search is new Traverse_Proc (Find_Object); + + -- Local variables + + Typ : constant Entity_Id := Etype (Defining_Identifier (Ren_Decl)); + + -- Start of processing for Find_Renamed_Object + + begin + -- Actions related to dispatching calls may appear as renamings of + -- tags. Do not process this type of renaming because it does not + -- use the actual value of the object. + + if not Is_RTE (Typ, RE_Tag_Ptr) then + Search (Name (Ren_Decl)); end if; - return Empty; - end Extract_Renamed_Object; + return Ren_Obj; + end Find_Renamed_Object; -- Local variables @@ -3954,7 +3966,7 @@ package body Exp_Util is end if; elsif Nkind (Stmt) = N_Object_Renaming_Declaration then - Ren_Obj := Extract_Renamed_Object (Stmt); + Ren_Obj := Find_Renamed_Object (Stmt); if Present (Ren_Obj) and then Ren_Obj = Trans_Id diff --git a/gcc/ada/init.c b/gcc/ada/init.c index 0e6fb11..02771d5 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -1747,6 +1747,29 @@ __gnat_set_features (void) __gnat_features_set = 1; } +/* Return true if the VMS version is 7.x. */ + +#define SYI$_VERSION 0x1000 + +int +__gnat_is_vms_v7 (void) +{ + struct descriptor_s desc; + char version[8]; + int status; + int code = SYI$_VERSION; + + desc.len = sizeof (version); + desc.mbz = 0; + desc.adr = version; + + status = lib$getsyi (&code, 0, &desc); + if ((status & 1) == 1 && version[1] == '7' && version[2] == '.') + return 1; + else + return 0; +} + /*******************/ /* FreeBSD Section */ /*******************/ diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index 5804da9..0fa421e 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -4364,8 +4364,10 @@ package body Prj.Nmsc is declare Name : constant String := Get_Name_String (Project.Library_Name); - OK : Boolean := Is_Letter (Name (Name'First)); + OK : Boolean := Is_Letter (Name (Name'First)); + Underline : Boolean := False; + begin for J in Name'First + 1 .. Name'Last loop exit when not OK; @@ -4385,7 +4387,7 @@ package body Prj.Nmsc is end if; end loop; - OK := OK and then not Underline; + OK := OK and not Underline; if not OK then Error_Msg @@ -4489,13 +4491,13 @@ package body Prj.Nmsc is Shared.String_Elements.Table (String_Element_Table.Last (Shared.String_Elements)) := - (Value => Name_Id (Source.Dep_Name), - Index => 0, - Display_Value => Name_Id (Source.Dep_Name), - Location => - Shared.String_Elements.Table (Interfaces).Location, - Flag => False, - Next => Interface_ALIs); + (Value => Name_Id (Source.Dep_Name), + Index => 0, + Display_Value => Name_Id (Source.Dep_Name), + Location => + Shared.String_Elements.Table (Interfaces).Location, + Flag => False, + Next => Interface_ALIs); Interface_ALIs := String_Element_Table.Last (Shared.String_Elements); diff --git a/gcc/ada/tracebak.c b/gcc/ada/tracebak.c index eedc715..a8a200d 100644 --- a/gcc/ada/tracebak.c +++ b/gcc/ada/tracebak.c @@ -259,7 +259,13 @@ struct layout #define FRAME_OFFSET(FP) 0 #define PC_ADJUST -4 -#define STOP_FRAME(CURRENT, TOP_STACK) ((CURRENT)->next == 0) + +/* According to the base PPC ABI, a toplevel frame entry should feature + a null backchain. What happens at signal handler frontiers isn't so + well specified, so we add a safety guard on top. */ + +#define STOP_FRAME(CURRENT, TOP_STACK) \ + ((CURRENT)->next == 0 || ((long)(CURRENT)->next % __alignof__(void*)) != 0) #define BASE_SKIP 1 -- 2.7.4