Commit c5f5123f by Arnaud Charlet

[multiple changes]

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.

From-SVN: r178457
parent 2bfa5484
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> 2011-09-02 Hristian Kirtchev <kirtchev@adacore.com>
* exp_ch3.adb (Expand_Freeze_Class_Wide_Type): Do not create * exp_ch3.adb (Expand_Freeze_Class_Wide_Type): Do not create
......
...@@ -1150,13 +1150,13 @@ package body Exp_Ch4 is ...@@ -1150,13 +1150,13 @@ package body Exp_Ch4 is
-- Set_Finalize_Address (<PtrT>FM, <T>FD'Unrestricted_Access); -- Set_Finalize_Address (<PtrT>FM, <T>FD'Unrestricted_Access);
-- Do not generate this call in the following cases: -- Do not generate this call in the following cases:
--
-- * .NET/JVM - these targets do not support address arithmetic -- * .NET/JVM - these targets do not support address arithmetic
-- and unchecked conversion, key elements of Finalize_Address. -- and unchecked conversion, key elements of Finalize_Address.
--
-- * Alfa mode - the call is useless and results in unwanted -- * Alfa mode - the call is useless and results in unwanted
-- expansion. -- expansion.
--
-- * CodePeer mode - TSS primitive Finalize_Address is not -- * CodePeer mode - TSS primitive Finalize_Address is not
-- created in this mode. -- created in this mode.
......
...@@ -6519,8 +6519,8 @@ package body Exp_Ch6 is ...@@ -6519,8 +6519,8 @@ package body Exp_Ch6 is
begin begin
-- Ada 2005 (AI-251): In class-wide interface objects we displace -- Ada 2005 (AI-251): In class-wide interface objects we displace
-- "this" to reference the base of the object required to get -- "this" to reference the base of the object. This is required to
-- access to the TSD of the object. -- get access to the TSD of the object.
if Is_Class_Wide_Type (Etype (Exp)) if Is_Class_Wide_Type (Etype (Exp))
and then Is_Interface (Etype (Exp)) and then Is_Interface (Etype (Exp))
......
...@@ -3887,49 +3887,61 @@ package body Exp_Util is ...@@ -3887,49 +3887,61 @@ package body Exp_Util is
(Trans_Id : Entity_Id; (Trans_Id : Entity_Id;
First_Stmt : Node_Id) return Boolean First_Stmt : Node_Id) return Boolean
is is
function Extract_Renamed_Object function Find_Renamed_Object (Ren_Decl : Node_Id) return Entity_Id;
(Ren_Decl : Node_Id) return Entity_Id;
-- Given an object renaming declaration, retrieve the entity of the -- Given an object renaming declaration, retrieve the entity of the
-- renamed name. Return Empty if the renamed name is anything other -- renamed name. Return Empty if the renamed name is anything other
-- than a variable or a constant. -- than a variable or a constant.
---------------------------- -------------------------
-- Extract_Renamed_Object -- -- Find_Renamed_Object --
---------------------------- -------------------------
function Extract_Renamed_Object function Find_Renamed_Object (Ren_Decl : Node_Id) return Entity_Id is
(Ren_Decl : Node_Id) return Entity_Id Ren_Obj : Node_Id := Empty;
is
Change : Boolean;
Ren_Obj : Node_Id;
begin function Find_Object (N : Node_Id) return Traverse_Result;
Change := True; -- Try to detect an object which is either a constant or a
Ren_Obj := Renamed_Object (Defining_Identifier (Ren_Decl)); -- variable.
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;
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 then
Ren_Obj := Expression (Ren_Obj); Ren_Obj := Entity (N);
Change := True; return Abandon;
end if; end if;
end loop;
if Nkind (Ren_Obj) in N_Has_Entity then return OK;
return Entity (Ren_Obj); 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; end if;
return Empty; return Ren_Obj;
end Extract_Renamed_Object; end Find_Renamed_Object;
-- Local variables -- Local variables
...@@ -3954,7 +3966,7 @@ package body Exp_Util is ...@@ -3954,7 +3966,7 @@ package body Exp_Util is
end if; end if;
elsif Nkind (Stmt) = N_Object_Renaming_Declaration then elsif Nkind (Stmt) = N_Object_Renaming_Declaration then
Ren_Obj := Extract_Renamed_Object (Stmt); Ren_Obj := Find_Renamed_Object (Stmt);
if Present (Ren_Obj) if Present (Ren_Obj)
and then Ren_Obj = Trans_Id and then Ren_Obj = Trans_Id
......
...@@ -1747,6 +1747,29 @@ __gnat_set_features (void) ...@@ -1747,6 +1747,29 @@ __gnat_set_features (void)
__gnat_features_set = 1; __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 */ /* FreeBSD Section */
/*******************/ /*******************/
......
...@@ -4364,8 +4364,10 @@ package body Prj.Nmsc is ...@@ -4364,8 +4364,10 @@ package body Prj.Nmsc is
declare declare
Name : constant String := Get_Name_String (Project.Library_Name); 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; Underline : Boolean := False;
begin begin
for J in Name'First + 1 .. Name'Last loop for J in Name'First + 1 .. Name'Last loop
exit when not OK; exit when not OK;
...@@ -4385,7 +4387,7 @@ package body Prj.Nmsc is ...@@ -4385,7 +4387,7 @@ package body Prj.Nmsc is
end if; end if;
end loop; end loop;
OK := OK and then not Underline; OK := OK and not Underline;
if not OK then if not OK then
Error_Msg Error_Msg
...@@ -4489,13 +4491,13 @@ package body Prj.Nmsc is ...@@ -4489,13 +4491,13 @@ package body Prj.Nmsc is
Shared.String_Elements.Table Shared.String_Elements.Table
(String_Element_Table.Last (Shared.String_Elements)) := (String_Element_Table.Last (Shared.String_Elements)) :=
(Value => Name_Id (Source.Dep_Name), (Value => Name_Id (Source.Dep_Name),
Index => 0, Index => 0,
Display_Value => Name_Id (Source.Dep_Name), Display_Value => Name_Id (Source.Dep_Name),
Location => Location =>
Shared.String_Elements.Table (Interfaces).Location, Shared.String_Elements.Table (Interfaces).Location,
Flag => False, Flag => False,
Next => Interface_ALIs); Next => Interface_ALIs);
Interface_ALIs := Interface_ALIs :=
String_Element_Table.Last (Shared.String_Elements); String_Element_Table.Last (Shared.String_Elements);
......
...@@ -259,7 +259,13 @@ struct layout ...@@ -259,7 +259,13 @@ struct layout
#define FRAME_OFFSET(FP) 0 #define FRAME_OFFSET(FP) 0
#define PC_ADJUST -4 #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 #define BASE_SKIP 1
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment