+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
-- 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.
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))
(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
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
__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 */
/*******************/
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;
end if;
end loop;
- OK := OK and then not Underline;
+ OK := OK and not Underline;
if not OK then
Error_Msg
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);
#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
projects / platform / upstream / gcc.git / commitdiff