2011-09-02 Robert Dewar <dewar@adacore.com>

	* exp_ch4.adb, exp_ch6.adb, prj-nmsc.adb: Minor reformatting.

2011-09-02  Hristian Kirtchev  <kirtchev@adacore.com>

	* 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  <gingold@adacore.com>

	* init.c: (__gnat_is_vms_v7): New function.

2011-09-02  Olivier Hainque  <hainque@adacore.com>

	* 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

7 files changed, 111 insertions, 47 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 98abf03e371..1f8cebfaed7 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,24 @@
+2011-09-02  Robert Dewar  <dewar@adacore.com>
+
+	* exp_ch4.adb, exp_ch6.adb, prj-nmsc.adb: Minor reformatting.
+
+2011-09-02  Hristian Kirtchev  <kirtchev@adacore.com>
+
+	* 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  <gingold@adacore.com>
+
+	* init.c: (__gnat_is_vms_v7): New function.
+
+2011-09-02  Olivier Hainque  <hainque@adacore.com>
+
+	* tracebak.c (STOP_FRAME, ppc elf/vxworks case): Stop on frames
+	that have a misaligned backchain, necessarily bogus.
+
 2011-09-02  Hristian Kirtchev  <kirtchev@adacore.com>
 
 	* 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 4e652eb2234..f3f20fc4652 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 (<PtrT>FM, <T>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 fd85a038871..3ff42b620e6 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 022f5f63612..34901abafd4 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 0e6fb11745c..02771d57c7c 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 5804da911cb..0fa421e7303 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 eedc715a2e5..a8a200d4486 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