summaryrefslogtreecommitdiff
path: root/gcc/ada
diff options
context:
space:
mode:
authorcharlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4>2014-08-04 13:02:44 +0000
committercharlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4>2014-08-04 13:02:44 +0000
commitba502e2bb99362d8916797aaa6b6cf44016ae714 (patch)
treecb6541747ff86af28069e975fb55ae8015015976 /gcc/ada
parentba33856e94d16c663e1334e7de4c8d46c5a33d80 (diff)
downloadgcc-ba502e2bb99362d8916797aaa6b6cf44016ae714.tar.gz
2014-08-04 Yannick Moy <moy@adacore.com>
* sem_ch3.adb (Analyze_Object_Declaration): In GNATprove mode, do not generate two Itypes with the same name for an array definition. * sinfo.ads: Expand doc on GNATprove mode. 2014-08-04 Hristian Kirtchev <kirtchev@adacore.com> * exp_ch3.adb (Expand_Freeze_Record_Type): Set the finalization master and storage pool attributes on the root type of an anonymous access type. * exp_ch4.adb (Expand_N_Allocator): Set the finalization master and storage pool attributes on the root type of an anonymous access type. 2014-08-04 Arnaud Charlet <charlet@adacore.com> * exp_ch3.adb: Minor reformatting. * tb-alvms.c, tb-alvxw.c, tb-ivms.c: Removed. * tracebak.c: Remove use of above files. * gcc-interface/Makefile.in: Update dependencies. 2014-08-04 Pierre-Marie Derodat <derodat@adacore.com> * gcc-interface/utils.c (gnat_set_type_context): Also set the context for parallel types' TYPE_STUB_DECL. Do not change anything if the context is already set for them. (gnat_pushdecl): Update the comment for calls to gnat_set_type_context to mention parallel types. (add_parallel_type): When adding a context-less parallel type to a type that has a context, propagate the context from the latter type to the former. (process_deferred_decl_context): Call gnat_set_type_context rather than manually setting the type context. (build_unc_object_type): Call gnat_set_type_context on the template type. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@213584 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/ada')
-rw-r--r--gcc/ada/ChangeLog38
-rw-r--r--gcc/ada/exp_ch3.adb172
-rw-r--r--gcc/ada/exp_ch4.adb22
-rw-r--r--gcc/ada/gcc-interface/Makefile.in4
-rw-r--r--gcc/ada/gcc-interface/utils.c45
-rw-r--r--gcc/ada/sem_ch3.adb8
-rw-r--r--gcc/ada/sinfo.ads4
-rw-r--r--gcc/ada/tb-alvms.c395
-rw-r--r--gcc/ada/tb-alvxw.c940
-rw-r--r--gcc/ada/tb-ivms.c88
-rw-r--r--gcc/ada/tracebak.c16
11 files changed, 190 insertions, 1542 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index c417df3a7af..4cc36d8a461 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,41 @@
+2014-08-04 Yannick Moy <moy@adacore.com>
+
+ * sem_ch3.adb (Analyze_Object_Declaration): In GNATprove mode,
+ do not generate two Itypes with the same name for an array
+ definition.
+ * sinfo.ads: Expand doc on GNATprove mode.
+
+2014-08-04 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_ch3.adb (Expand_Freeze_Record_Type): Set the finalization
+ master and storage pool attributes on the root type of an
+ anonymous access type.
+ * exp_ch4.adb (Expand_N_Allocator): Set the finalization master
+ and storage pool attributes on the root type of an anonymous
+ access type.
+
+2014-08-04 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_ch3.adb: Minor reformatting.
+ * tb-alvms.c, tb-alvxw.c, tb-ivms.c: Removed.
+ * tracebak.c: Remove use of above files.
+ * gcc-interface/Makefile.in: Update dependencies.
+
+2014-08-04 Pierre-Marie Derodat <derodat@adacore.com>
+
+ * gcc-interface/utils.c (gnat_set_type_context): Also set the
+ context for parallel types' TYPE_STUB_DECL. Do not change
+ anything if the context is already set for them.
+ (gnat_pushdecl): Update the comment for calls to
+ gnat_set_type_context to mention parallel types.
+ (add_parallel_type): When adding a context-less parallel type to
+ a type that has a context, propagate the context from the latter
+ type to the former.
+ (process_deferred_decl_context): Call gnat_set_type_context
+ rather than manually setting the type context.
+ (build_unc_object_type): Call gnat_set_type_context on the
+ template type.
+
2014-08-04 Ed Schonberg <schonberg@adacore.com>
* exp_ch5.adb (Expand_N_Case_Statement): If a choice is a
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 2f21d488dd0..476b42e3c07 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -7235,35 +7235,39 @@ package body Exp_Ch3 is
Master_Built := True;
-- All anonymous access-to-controlled types allocate
- -- on the global pool.
+ -- on the global pool. Note that the finalization
+ -- master and the associated storage pool must be set
+ -- on the root type (both are "root type only").
Set_Associated_Storage_Pool
- (Comp_Typ, RTE (RE_Global_Pool_Object));
+ (Root_Type (Comp_Typ), RTE (RE_Global_Pool_Object));
Build_Finalization_Master
- (Typ => Comp_Typ,
+ (Typ => Root_Type (Comp_Typ),
Ins_Node => Ins_Node,
Encl_Scope => Encl_Scope);
Fin_Mas_Id := Finalization_Master (Comp_Typ);
-- Subsequent anonymous access-to-controlled components
- -- reuse the already available master.
+ -- reuse the available master.
else
-- All anonymous access-to-controlled types allocate
- -- on the global pool.
+ -- on the global pool. Note that both the finalization
+ -- master and the associated storage pool must be set
+ -- on the root type (both are "root type only").
Set_Associated_Storage_Pool
- (Comp_Typ, RTE (RE_Global_Pool_Object));
+ (Root_Type (Comp_Typ), RTE (RE_Global_Pool_Object));
-- Shared the master among multiple components
- Set_Finalization_Master (Comp_Typ, Fin_Mas_Id);
+ Set_Finalization_Master
+ (Root_Type (Comp_Typ), Fin_Mas_Id);
-- Convert the master into a heterogeneous collection.
-- Generate:
- --
-- Set_Is_Heterogeneous (<Fin_Mas_Id>);
if not Attributes_Set then
@@ -7271,7 +7275,7 @@ package body Exp_Ch3 is
Insert_Action (Ins_Node,
Make_Procedure_Call_Statement (Loc,
- Name =>
+ Name =>
New_Occurrence_Of
(RTE (RE_Set_Is_Heterogeneous), Loc),
Parameter_Associations => New_List (
@@ -7330,9 +7334,7 @@ package body Exp_Ch3 is
-- Primitive operations of tagged types are frozen when the dispatch
-- table is constructed.
- if not Comes_From_Source (Typ)
- or else Is_Tagged_Type (Typ)
- then
+ if not Comes_From_Source (Typ) or else Is_Tagged_Type (Typ) then
return;
end if;
@@ -7342,7 +7344,7 @@ package body Exp_Ch3 is
if Present (Stream_Op)
and then Is_Subprogram (Stream_Op)
and then Nkind (Unit_Declaration_Node (Stream_Op)) =
- N_Subprogram_Declaration
+ N_Subprogram_Declaration
and then not Is_Frozen (Stream_Op)
then
Append_Freeze_Actions (Typ, Freeze_Entity (Stream_Op, N));
@@ -7371,9 +7373,9 @@ package body Exp_Ch3 is
if Present (Access_Types_To_Process (N)) then
declare
E : Elmt_Id := First_Elmt (Access_Types_To_Process (N));
+
begin
while Present (E) loop
-
if Is_Remote_Access_To_Class_Wide_Type (Node (E)) then
Validate_RACW_Primitives (Node (E));
RACW_Seen := True;
@@ -7395,7 +7397,6 @@ package body Exp_Ch3 is
if Is_Record_Type (Def_Id) then
if Ekind (Def_Id) = E_Record_Type then
Expand_Freeze_Record_Type (N);
-
elsif Is_Class_Wide_Type (Def_Id) then
Expand_Freeze_Class_Wide_Type (N);
end if;
@@ -7460,21 +7461,18 @@ package body Exp_Ch3 is
if Is_Composite_Type (Desig_Type)
and then not Is_Constrained (Desig_Type)
then
- DT_Size :=
- Make_Integer_Literal (Loc, 0);
-
- DT_Align :=
- Make_Integer_Literal (Loc, Maximum_Alignment);
+ DT_Size := Make_Integer_Literal (Loc, 0);
+ DT_Align := Make_Integer_Literal (Loc, Maximum_Alignment);
else
DT_Size :=
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Desig_Type, Loc),
+ Prefix => New_Occurrence_Of (Desig_Type, Loc),
Attribute_Name => Name_Max_Size_In_Storage_Elements);
DT_Align :=
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Desig_Type, Loc),
+ Prefix => New_Occurrence_Of (Desig_Type, Loc),
Attribute_Name => Name_Alignment);
end if;
@@ -7508,26 +7506,26 @@ package body Exp_Ch3 is
Append_Freeze_Action (Freeze_Action_Typ,
Make_Object_Declaration (Loc,
Defining_Identifier => Pool_Object,
- Object_Definition =>
+ Object_Definition =>
Make_Subtype_Indication (Loc,
Subtype_Mark =>
New_Occurrence_Of
(RTE (RE_Stack_Bounded_Pool), Loc),
- Constraint =>
+ Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => New_List (
- -- First discriminant is the Pool Size
+ -- First discriminant is the Pool Size
New_Occurrence_Of (
Storage_Size_Variable (Def_Id), Loc),
- -- Second discriminant is the element size
+ -- Second discriminant is the element size
DT_Size,
- -- Third discriminant is the alignment
+ -- Third discriminant is the alignment
DT_Align)))));
end;
@@ -7575,8 +7573,8 @@ package body Exp_Ch3 is
if Is_Ancestor (RSPWS, Etype (Pool)) then
Error_Msg_N
- ("??subpool access type has deeper accessibility " &
- "level than pool", Def_Id);
+ ("??subpool access type has deeper accessibility "
+ & "level than pool", Def_Id);
Append_Freeze_Action (Def_Id,
Make_Raise_Program_Error (Loc,
@@ -7593,10 +7591,9 @@ package body Exp_Ch3 is
elsif Is_Class_Wide_Type (Etype (Pool)) then
Append_Freeze_Action (Def_Id,
Make_If_Statement (Loc,
- Condition =>
+ Condition =>
Make_In (Loc,
- Left_Opnd =>
- New_Occurrence_Of (Pool, Loc),
+ Left_Opnd => New_Occurrence_Of (Pool, Loc),
Right_Opnd =>
New_Occurrence_Of
(Class_Wide_Type (RSPWS), Loc)),
@@ -8016,7 +8013,7 @@ package body Exp_Ch3 is
Make_Aggregate (Loc,
Component_Associations => New_List (
Make_Component_Association (Loc,
- Choices => New_List (
+ Choices => New_List (
Make_Others_Choice (Loc)),
Expression =>
Get_Simple_Init_Val
@@ -8112,17 +8109,16 @@ package body Exp_Ch3 is
-- other checks.
declare
- Bod : Node_Id;
+ Bod : Node_Id;
Inv_Id : constant Entity_Id := Invariant_Procedure (Typ);
- Call : constant Node_Id :=
+ Call : constant Node_Id :=
Make_Procedure_Call_Statement (Sloc (N),
- Name => New_Occurrence_Of (Proc_Id, Loc),
+ Name => New_Occurrence_Of (Proc_Id, Loc),
Parameter_Associations =>
New_List
(New_Occurrence_Of (First_Formal (Inv_Id), Loc)));
begin
-
-- The invariant body has not been analyzed yet, so we do a
-- sequential search forward, and retrieve it by name.
@@ -8229,11 +8225,10 @@ package body Exp_Ch3 is
Formals := New_List (
Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uInit),
- In_Present => True,
- Out_Present => True,
- Parameter_Type => New_Occurrence_Of (Typ, Loc)));
+ Defining_Identifier => Make_Defining_Identifier (Loc, Name_uInit),
+ In_Present => True,
+ Out_Present => True,
+ Parameter_Type => New_Occurrence_Of (Typ, Loc)));
-- For task record value, or type that contains tasks, add two more
-- formals, _Master : Master_Id and _Chain : in out Activation_Chain
@@ -8324,9 +8319,9 @@ package body Exp_Ch3 is
if not Is_Ancestor (Iface, Typ, Use_Full_View => True) then
Append_To (Stmts_List,
Make_Assignment_Statement (Loc,
- Name =>
+ Name =>
Make_Selected_Component (Loc,
- Prefix => New_Copy_Tree (Target),
+ Prefix => New_Copy_Tree (Target),
Selector_Name => New_Occurrence_Of (Tag_Comp, Loc)),
Expression =>
New_Occurrence_Of (Iface_Tag, Loc)));
@@ -8362,8 +8357,8 @@ package body Exp_Ch3 is
Append_To (Stmts_List,
Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of
- (RTE (RE_Set_Dynamic_Offset_To_Top), Loc),
+ Name =>
+ New_Occurrence_Of (RTE (RE_Set_Dynamic_Offset_To_Top), Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix => New_Copy_Tree (Target),
@@ -8398,11 +8393,12 @@ package body Exp_Ch3 is
Append_To (Stmts_List,
Make_Assignment_Statement (Loc,
- Name =>
+ Name =>
Make_Selected_Component (Loc,
- Prefix => New_Copy_Tree (Target),
- Selector_Name => New_Occurrence_Of
- (Offset_To_Top_Comp, Loc)),
+ Prefix => New_Copy_Tree (Target),
+ Selector_Name =>
+ New_Occurrence_Of (Offset_To_Top_Comp, Loc)),
+
Expression =>
Make_Attribute_Reference (Loc,
Prefix =>
@@ -8424,7 +8420,7 @@ package body Exp_Ch3 is
Offset_Value =>
Unchecked_Convert_To (RTE (RE_Storage_Offset),
Make_Attribute_Reference (Loc,
- Prefix =>
+ Prefix =>
Make_Selected_Component (Loc,
Prefix => New_Copy_Tree (Target),
Selector_Name =>
@@ -8443,8 +8439,9 @@ package body Exp_Ch3 is
if RTE_Available (RE_Register_Interface_Offset) then
Append_To (Stmts_List,
Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of
- (RTE (RE_Register_Interface_Offset), Loc),
+ Name =>
+ New_Occurrence_Of
+ (RTE (RE_Register_Interface_Offset), Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix => New_Copy_Tree (Target),
@@ -8456,14 +8453,13 @@ package body Exp_Ch3 is
New_Occurrence_Of (Standard_True, Loc),
- Unchecked_Convert_To
- (RTE (RE_Storage_Offset),
- Make_Attribute_Reference (Loc,
- Prefix =>
- Make_Selected_Component (Loc,
- Prefix => New_Copy_Tree (Target),
- Selector_Name =>
- New_Occurrence_Of (Tag_Comp, Loc)),
+ Unchecked_Convert_To (RTE (RE_Storage_Offset),
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Copy_Tree (Target),
+ Selector_Name =>
+ New_Occurrence_Of (Tag_Comp, Loc)),
Attribute_Name => Name_Position)),
Make_Null (Loc))));
@@ -8537,8 +8533,8 @@ package body Exp_Ch3 is
then
exit when
(Is_Record_Type (Comp_Typ)
- and then Is_Variable_Size_Record
- (Base_Type (Comp_Typ)))
+ and then
+ Is_Variable_Size_Record (Base_Type (Comp_Typ)))
or else
(Is_Array_Type (Comp_Typ)
and then Is_Variable_Size_Array (Comp_Typ));
@@ -8551,7 +8547,7 @@ package body Exp_Ch3 is
Error_Msg_Node_2 := Comp;
Error_Msg_NE
("parent type & with dynamic component & cannot be parent"
- & " of 'C'P'P derivation if new interfaces are present",
+ & " of 'C'P'P derivation if new interfaces are present",
Typ, Scope (Original_Record_Component (Comp)));
Error_Msg_Sloc :=
@@ -8760,16 +8756,17 @@ package body Exp_Ch3 is
Make_Simple_Return_Statement (Loc,
Expression =>
Make_Extension_Aggregate (Loc,
- Ancestor_Part =>
+ Ancestor_Part =>
Make_Function_Call (Loc,
- Name => New_Occurrence_Of (Alias (Subp), Loc),
+ Name =>
+ New_Occurrence_Of (Alias (Subp), Loc),
Parameter_Associations => Actual_List),
Null_Record_Present => True));
Func_Body :=
Make_Subprogram_Body (Loc,
- Specification => New_Copy_Tree (Func_Spec),
- Declarations => Empty_List,
+ Specification => New_Copy_Tree (Func_Spec),
+ Declarations => Empty_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (Return_Stmt)));
@@ -9223,7 +9220,7 @@ package body Exp_Ch3 is
Expression =>
Make_Op_Not (Loc,
Make_Function_Call (Loc,
- Name => New_Occurrence_Of (Target, Loc),
+ Name => New_Occurrence_Of (Target, Loc),
Parameter_Associations => New_List (
Make_Identifier (Loc, Chars (Left_Op)),
Make_Identifier (Loc, Chars (Right_Op)))))));
@@ -9287,15 +9284,14 @@ package body Exp_Ch3 is
-- of the interface type)
if Is_Controlling_Formal (Formal) then
- if Nkind (Parameter_Type (Parent (Formal)))
- = N_Identifier
+ if Nkind (Parameter_Type (Parent (Formal))) = N_Identifier
then
Set_Parameter_Type (New_Param_Spec,
New_Occurrence_Of (Tag_Typ, Loc));
else pragma Assert
- (Nkind (Parameter_Type (Parent (Formal)))
- = N_Access_Definition);
+ (Nkind (Parameter_Type (Parent (Formal))) =
+ N_Access_Definition);
Set_Subtype_Mark (Parameter_Type (New_Param_Spec),
New_Occurrence_Of (Tag_Typ, Loc));
end if;
@@ -9310,10 +9306,10 @@ package body Exp_Ch3 is
Append_To (Decl_List,
Make_Subprogram_Declaration (Loc,
Make_Procedure_Specification (Loc,
- Defining_Unit_Name =>
+ Defining_Unit_Name =>
Make_Defining_Identifier (Loc, Chars (Subp)),
Parameter_Specifications => Formal_List,
- Null_Present => True)));
+ Null_Present => True)));
end if;
Next_Elmt (Prim_Elmt);
@@ -9352,7 +9348,7 @@ package body Exp_Ch3 is
Loc : constant Source_Ptr := Sloc (Tag_Typ);
Res : constant List_Id := New_List;
- Eq_Name : Name_Id := Name_Op_Eq;
+ Eq_Name : Name_Id := Name_Op_Eq;
Eq_Needed : Boolean;
Eq_Spec : Node_Id;
Prim : Elmt_Id;
@@ -9482,11 +9478,12 @@ package body Exp_Ch3 is
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_X),
- Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)),
+ Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)),
+
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_Y),
- Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))),
+ Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))),
Ret_Type => Standard_Boolean);
Append_To (Res, Eq_Spec);
@@ -9588,9 +9585,8 @@ package body Exp_Ch3 is
Specification =>
Make_Disp_Timed_Select_Spec (Tag_Typ)));
- -- If the ancestor is an interface type we declare non-abstract
- -- primitives to override the abstract primitives of the interface
- -- type.
+ -- If ancestor is an interface type, declare non-abstract primitives
+ -- to override the abstract primitives of the interface type.
-- In VM targets we define these primitives in all root tagged types
-- that are not interface types. Done because in VM targets we don't
@@ -9675,8 +9671,7 @@ package body Exp_Ch3 is
Consider_IS : Boolean := True) return Boolean
is
Consider_IS_NS : constant Boolean :=
- Normalize_Scalars
- or (Initialize_Scalars and Consider_IS);
+ Normalize_Scalars or (Initialize_Scalars and Consider_IS);
begin
-- Never need initialization if it is suppressed
@@ -9691,7 +9686,6 @@ package body Exp_Ch3 is
if Is_Private_Type (T) then
declare
RT : constant Entity_Id := Underlying_Type (T);
-
begin
if Present (RT) then
return Needs_Simple_Initialization (RT);
@@ -10014,8 +10008,7 @@ package body Exp_Ch3 is
if Stream_Operation_OK (Tag_Typ, TSS_Stream_Output)
and then No (TSS (Tag_Typ, TSS_Stream_Output))
then
- Build_Record_Or_Elementary_Output_Procedure
- (Loc, Tag_Typ, Decl, Ent);
+ Build_Record_Or_Elementary_Output_Procedure (Loc, Tag_Typ, Decl, Ent);
Append_To (Res, Decl);
end if;
@@ -10063,9 +10056,8 @@ package body Exp_Ch3 is
Append_To (Res, Make_Disp_Timed_Select_Body (Tag_Typ));
end if;
- if not Is_Limited_Type (Tag_Typ)
- and then not Is_Interface (Tag_Typ)
- then
+ if not Is_Limited_Type (Tag_Typ) and then not Is_Interface (Tag_Typ) then
+
-- Body for equality
if Eq_Needed then
@@ -10126,6 +10118,7 @@ package body Exp_Ch3 is
Make_Adjust_Call (
Obj_Ref => Make_Identifier (Loc, Name_V),
Typ => Tag_Typ))));
+
else
Set_Handled_Statement_Sequence (Decl,
Make_Handled_Sequence_Of_Statements (Loc,
@@ -10145,6 +10138,7 @@ package body Exp_Ch3 is
Make_Final_Call
(Obj_Ref => Make_Identifier (Loc, Name_V),
Typ => Tag_Typ))));
+
else
Set_Handled_Statement_Sequence (Decl,
Make_Handled_Sequence_Of_Statements (Loc,
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index dfa22bd70ae..9068fdcdfbb 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -1124,10 +1124,11 @@ package body Exp_Ch4 is
-- Inherit the allocation-related attributes from the original
-- access type.
- Set_Finalization_Master (Def_Id, Finalization_Master (PtrT));
+ Set_Finalization_Master
+ (Def_Id, Finalization_Master (PtrT));
- Set_Associated_Storage_Pool (Def_Id,
- Associated_Storage_Pool (PtrT));
+ Set_Associated_Storage_Pool
+ (Def_Id, Associated_Storage_Pool (PtrT));
-- Declare the object using the previous type declaration
@@ -4318,26 +4319,29 @@ package body Exp_Ch4 is
-- Anonymous access-to-controlled types allocate on the global pool.
-- Do not set this attribute on .NET/JVM since those targets do not
- -- support pools.
+ -- support pools. Note that this is a "root type only" attribute.
if No (Associated_Storage_Pool (PtrT)) and then VM_Target = No_VM then
if Present (Rel_Typ) then
Set_Associated_Storage_Pool
- (PtrT, Associated_Storage_Pool (Rel_Typ));
+ (Root_Type (PtrT), Associated_Storage_Pool (Rel_Typ));
else
Set_Associated_Storage_Pool
- (PtrT, RTE (RE_Global_Pool_Object));
+ (Root_Type (PtrT), RTE (RE_Global_Pool_Object));
end if;
end if;
-- The finalization master must be inserted and analyzed as part of
-- the current semantic unit. Note that the master is updated when
- -- analysis changes current units.
+ -- analysis changes current units. Note that this is a "root type
+ -- only" attribute.
if Present (Rel_Typ) then
- Set_Finalization_Master (PtrT, Finalization_Master (Rel_Typ));
+ Set_Finalization_Master
+ (Root_Type (PtrT), Finalization_Master (Rel_Typ));
else
- Set_Finalization_Master (PtrT, Current_Anonymous_Master);
+ Set_Finalization_Master
+ (Root_Type (PtrT), Current_Anonymous_Master);
end if;
end if;
diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in
index 07d9828f775..03df9321765 100644
--- a/gcc/ada/gcc-interface/Makefile.in
+++ b/gcc/ada/gcc-interface/Makefile.in
@@ -515,7 +515,7 @@ ifeq ($(strip $(filter-out m68k% wrs vx%,$(target_cpu) $(target_vendor) $(target
endif
# PowerPC and e500v2 VxWorks
-ifeq ($(strip $(filter-out powerpc% wrs vxworks,$(target_cpu) $(target_vendor) $(target_os))),)
+ifeq ($(strip $(filter-out powerpc% wrs vxworks vxworks7,$(target_cpu) $(target_vendor) $(target_os))),)
ifeq ($(strip $(filter-out e500%, $(target_alias))),)
ARCH_STR=e500
@@ -3012,7 +3012,7 @@ a-tags.o : a-tags.adb a-tags.ads
# need to keep the frame pointer in this file to pop the stack properly on
# some targets.
-tracebak.o : tracebak.c tb-alvms.c tb-alvxw.c tb-gcc.c
+tracebak.o : tracebak.c tb-gcc.c
$(COMPILER) -c $(ALL_COMPILERFLAGS) $(ADA_CFLAGS) $(ALL_CPPFLAGS) \
$(INCLUDES) -fno-omit-frame-pointer $< $(OUTPUT_OPTION)
diff --git a/gcc/ada/gcc-interface/utils.c b/gcc/ada/gcc-interface/utils.c
index 918b6cc021c..9f81eae8157 100644
--- a/gcc/ada/gcc-interface/utils.c
+++ b/gcc/ada/gcc-interface/utils.c
@@ -575,7 +575,18 @@ gnat_set_type_context (tree type, tree context)
while (decl && DECL_PARALLEL_TYPE (decl))
{
- TYPE_CONTEXT (DECL_PARALLEL_TYPE (decl)) = context;
+ tree parallel_type = DECL_PARALLEL_TYPE (decl);
+
+ /* Give a context to the parallel types and their stub decl, if any.
+ Some parallel types seems to be present in multiple parallel type
+ chains, so don't mess with their context if they already have one. */
+ if (TYPE_CONTEXT (parallel_type) == NULL_TREE)
+ {
+ if (TYPE_STUB_DECL (parallel_type) != NULL_TREE)
+ DECL_CONTEXT (TYPE_STUB_DECL (parallel_type)) = context;
+ TYPE_CONTEXT (parallel_type) = context;
+ }
+
decl = TYPE_STUB_DECL (DECL_PARALLEL_TYPE (decl));
}
}
@@ -799,7 +810,9 @@ gnat_pushdecl (tree decl, Node_Id gnat_node)
t = NULL_TREE;
/* Propagate the name to all the anonymous variants. This is needed
- for the type qualifiers machinery to work properly. */
+ for the type qualifiers machinery to work properly. Also propagate
+ the context to them. Note that the context will be propagated to all
+ parallel types too thanks to gnat_set_type_context. */
if (t)
for (t = TYPE_MAIN_VARIANT (t); t; t = TYPE_NEXT_VARIANT (t))
if (!(TYPE_NAME (t) && TREE_CODE (TYPE_NAME (t)) == TYPE_DECL))
@@ -1763,7 +1776,10 @@ finish_record_type (tree record_type, tree field_list, int rep_level,
rest_of_record_type_compilation (record_type);
}
-/* Append PARALLEL_TYPE on the chain of parallel types of TYPE. */
+/* Append PARALLEL_TYPE on the chain of parallel types of TYPE. If
+ PARRALEL_TYPE has no context and its computation is not deferred yet, also
+ propagate TYPE's context to PARALLEL_TYPE's or defer its propagation to the
+ moment TYPE will get a context. */
void
add_parallel_type (tree type, tree parallel_type)
@@ -1774,6 +1790,19 @@ add_parallel_type (tree type, tree parallel_type)
decl = TYPE_STUB_DECL (DECL_PARALLEL_TYPE (decl));
SET_DECL_PARALLEL_TYPE (decl, parallel_type);
+
+ /* If PARALLEL_TYPE already has a context, we are done. */
+ if (TYPE_CONTEXT (parallel_type) != NULL_TREE)
+ return;
+
+ /* Otherwise, try to get one from TYPE's context. */
+ if (TYPE_CONTEXT (type) != NULL_TREE)
+ /* TYPE already has a context, so simply propagate it to PARALLEL_TYPE. */
+ gnat_set_type_context (parallel_type, TYPE_CONTEXT (type));
+
+ /* ... otherwise TYPE has not context yet. We know it will thanks to
+ gnat_pushdecl, and then its context will be propagated to PARALLEL_TYPE.
+ So we have nothing to do in this case. */
}
/* Return true if TYPE has a parallel type. */
@@ -2851,7 +2880,7 @@ process_deferred_decl_context (bool force)
..._TYPE nodes. */
FOR_EACH_VEC_ELT (node->types, i, t)
{
- TYPE_CONTEXT (t) = context;
+ gnat_set_type_context (t, context);
}
processed = true;
}
@@ -3629,6 +3658,7 @@ tree
build_unc_object_type (tree template_type, tree object_type, tree name,
bool debug_info_p)
{
+ tree decl;
tree type = make_node (RECORD_TYPE);
tree template_field
= create_field_decl (get_identifier ("BOUNDS"), template_type, type,
@@ -3644,7 +3674,12 @@ build_unc_object_type (tree template_type, tree object_type, tree name,
/* Declare it now since it will never be declared otherwise. This is
necessary to ensure that its subtrees are properly marked. */
- create_type_decl (name, type, true, debug_info_p, Empty);
+ decl = create_type_decl (name, type, true, debug_info_p, Empty);
+
+ /* template_type will not be used elsewhere than here, so to keep the debug
+ info clean and in order to avoid scoping issues, make decl its
+ context. */
+ gnat_set_type_context (template_type, decl);
return type;
}
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 351ae87b52c..695b27ef169 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -3769,6 +3769,14 @@ package body Sem_Ch3 is
elsif Is_Interface (T) then
null;
+ -- In GNATprove mode, Expand_Subtype_From_Expr does nothing. Thus,
+ -- we should prevent the generation of another Itype with the
+ -- same name as the one already generated, or we end up with
+ -- two identical types in GNATprove.
+
+ elsif GNATprove_Mode then
+ null;
+
else
Expand_Subtype_From_Expr (N, T, Object_Definition (N), E);
Act_T := Find_Type_Of_Object (Object_Definition (N), N);
diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads
index 8921d657093..85a0d537225 100644
--- a/gcc/ada/sinfo.ads
+++ b/gcc/ada/sinfo.ads
@@ -577,6 +577,10 @@ package Sinfo is
-- warning issued when generating code, to avoid formal verification
-- of a partial unit.
+ -- 4. Unconstrained types are not replaced by constrained types whose
+ -- bounds are generated from an expression: Expand_Subtype_From_Expr
+ -- should be noop.
+
-----------------------
-- Check Flag Fields --
-----------------------
diff --git a/gcc/ada/tb-alvms.c b/gcc/ada/tb-alvms.c
deleted file mode 100644
index 1fd837e150c..00000000000
--- a/gcc/ada/tb-alvms.c
+++ /dev/null
@@ -1,395 +0,0 @@
-/****************************************************************************
- * *
- * GNAT RUN-TIME COMPONENTS *
- * *
- * T R A C E B A C K - A l p h a / V M S *
- * *
- * C Implementation File *
- * *
- * Copyright (C) 2003-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- *
- * ware Foundation; either version 3, or (at your option) any later ver- *
- * sion. GNAT is distributed in the hope that it will be useful, but WITH- *
- * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
- * or FITNESS FOR A PARTICULAR PURPOSE. *
- * *
- * As a special exception under Section 7 of GPL version 3, you are granted *
- * additional permissions described in the GCC Runtime Library Exception, *
- * version 3.1, as published by the Free Software Foundation. *
- * *
- * You should have received a copy of the GNU General Public License and *
- * a copy of the GCC Runtime Library Exception along with this program; *
- * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see *
- * <http://www.gnu.org/licenses/>. *
- * *
- * GNAT was originally developed by the GNAT team at New York University. *
- * Extensive contributions were provided by Ada Core Technologies Inc. *
- * *
- ****************************************************************************/
-
-
-/* Alpha VMS requires a special treatment due to the complexity of the ABI.
- What is here is along the lines of what the MD_FALLBACK_FRAME_STATE_FOR
- macro does for frame unwinding during exception propagation. This file is
- #included within tracebak.c in the appropriate case.
-
- Most of the contents is directed by the OpenVMS/Alpha Conventions (ABI)
- document, sections of which we will refer to as ABI-<section_number>. */
-
-#include <vms/pdscdef.h>
-#include <vms/libicb.h>
-#include <vms/chfctxdef.h>
-#include <vms/chfdef.h>
-
-/* A couple of items missing from the header file included above. */
-extern void * SYS$GL_CALL_HANDL;
-#define PDSC$M_BASE_FRAME (1 << 10)
-
-/* Registers are 64bit wide and addresses are 32bit wide on alpha-vms. */
-typedef void * ADDR;
-typedef unsigned long long REG;
-
-#define REG_AT(addr) (*(REG *)(addr))
-
-#define AS_REG(addr) ((REG)(unsigned long)(addr))
-#define AS_ADDR(reg) ((ADDR)(unsigned long)(reg))
-#define ADDR_IN(reg) (AS_ADDR(reg))
-
-/* The following structure defines the state maintained during the
- unwinding process. */
-typedef struct
-{
- ADDR pc; /* Address of the call insn involved in the chain. */
- ADDR sp; /* Stack Pointer at the time of this call. */
- ADDR fp; /* Frame Pointer at the time of this call. */
-
- /* The values above are fetched as saved REGisters on the stack. They are
- typed ADDR because this is what the values in those registers are. */
-
- /* Values of the registers saved by the functions in the chain,
- incrementally updated through consecutive calls to the "unwind" function
- below. */
- REG saved_regs [32];
-} frame_state_t;
-
-/* Shortcuts for saved_regs of specific interest:
-
- Frame Pointer is r29,
- Stack Pointer is r30,
- Return Address is r26,
- Procedure Value is r27.
-
- This is from ABI-3.1.1 [Integer Registers]. */
-
-#define saved_fpr saved_regs[29]
-#define saved_spr saved_regs[30]
-#define saved_rar saved_regs[26]
-#define saved_pvr saved_regs[27]
-
-/* Special values for saved_rar, used to control the overall unwinding
- process. */
-#define RA_UNKNOWN ((REG)~0)
-#define RA_STOP ((REG)0)
-
-/* We still use a number of macros similar to the ones for the generic
- __gnat_backtrace implementation. */
-#define PC_ADJUST 4
-#define STOP_FRAME (frame_state.saved_rar == RA_STOP)
-
-/* Compute Procedure Value from Frame Pointer value. This follows the rules
- in ABI-3.6.1 [Current Procedure]. */
-#define PV_FOR(FP) \
- (((FP) != 0) \
- ? (((REG_AT (FP) & 0x7) == 0) ? *(PDSCDEF **)(FP) : (PDSCDEF *)(FP)) : 0)
-
-
-/**********
- * unwind *
- **********/
-
-/* Helper for __gnat_backtrace.
-
- FS represents some call frame, identified by a pc and associated frame
- pointer in FS->pc and FS->fp. FS->saved_regs contains the state of the
- general registers upon entry in this frame. Of most interest in this set
- are the saved return address and frame pointer registers, which actually
- allow identifying the caller's frame.
-
- This routine "unwinds" the input frame state by adjusting it to eventually
- represent its caller's frame. The basic principle is to shift the fp and pc
- saved values into the current state, and then compute the corresponding new
- saved registers set.
-
- If the call chain goes through a signal handler, special processing is
- required when we process the kernel frame which has called the handler, to
- switch it to the interrupted context frame. */
-
-#define K_HANDLER_FRAME(fs) (PV_FOR ((fs)->fp) == SYS$GL_CALL_HANDL)
-
-static void unwind_regular_code (frame_state_t * fs);
-static void unwind_kernel_handler (frame_state_t * fs);
-
-void
-unwind (frame_state_t * fs)
-{
- /* Don't do anything if requested so. */
- if (fs->saved_rar == RA_STOP)
- return;
-
- /* Retrieve the values of interest computed during the previous
- call. PC_ADJUST gets us from the return address to the call insn
- address. */
- fs->pc = ADDR_IN (fs->saved_rar) - PC_ADJUST;
- fs->sp = ADDR_IN (fs->saved_spr);
- fs->fp = ADDR_IN (fs->saved_fpr);
-
- /* Unless we are able to determine otherwise, set the frame state's
- saved return address such that the unwinding process will stop. */
- fs->saved_rar = RA_STOP;
-
- /* Now we want to update fs->saved_regs to reflect the state of the caller
- of the procedure described by pc/fp.
-
- The condition to check for a special kernel frame which has called a
- signal handler is stated in ABI-6.7.1 [Signaler's Registers] : "The frame
- of the call to the handler can be identified by the return address of
- SYS$CALL_HANDL+4". We use the equivalent procedure value identification
- here because SYS$CALL_HANDL appears to be undefined. */
-
- if (K_HANDLER_FRAME (fs))
- unwind_kernel_handler (fs);
- else
- unwind_regular_code (fs);
-}
-
-/***********************
- * unwind_regular_code *
- ***********************/
-
-/* Helper for unwind, for the case of unwinding through regular code which
- is not a signal handler. */
-
-static void
-unwind_regular_code (frame_state_t * fs)
-{
- PDSCDEF * pv = PV_FOR (fs->fp);
-
- ADDR frame_base;
-
- /* Use the procedure value to unwind, in a way depending on the kind of
- procedure at hand. See ABI-3.3 [Procedure Representation] and ABI-3.4
- [Procedure Types]. */
-
- if (pv == 0
- || pv->pdsc$w_flags & PDSC$M_BASE_FRAME)
- return;
-
- frame_base
- = (pv->pdsc$w_flags & PDSC$M_BASE_REG_IS_FP) ? fs->fp : fs->sp;
-
- switch (pv->pdsc$w_flags & 0xf)
- {
- case PDSC$K_KIND_FP_STACK:
- /* Stack Frame Procedure (ABI-3.4.1). Retrieve the necessary registers
- from the Register Save Area in the frame. */
- {
- ADDR rsa_base = frame_base + pv->pdsc$w_rsa_offset;
- int i, j;
-
- fs->saved_rar = REG_AT (rsa_base);
- fs->saved_pvr = REG_AT (frame_base);
-
- for (i = 0, j = 0; i < 32; i++)
- if (pv->pdsc$l_ireg_mask & (1 << i))
- fs->saved_regs[i] = REG_AT (rsa_base + 8 * ++j);
-
- /* Note that the loop above is guaranteed to set fs->saved_fpr,
- because "The preserved register set must always include R29(FP)
- since it will always be used." (ABI-3.4.3.4 [Register Save Area for
- All Stack Frames]).
-
- Also note that we need to run through all the registers to ensure
- that unwinding through register procedures (see below) gets the
- right values out of the saved_regs array. */
- }
- break;
-
- case PDSC$K_KIND_FP_REGISTER:
- /* Register Procedure (ABI-3.4.4). Retrieve the necessary registers from
- the registers where they have been saved. */
- {
- fs->saved_rar = fs->saved_regs[pv->pdsc$b_save_ra];
- fs->saved_fpr = fs->saved_regs[pv->pdsc$b_save_fp];
- }
- break;
-
- default:
- /* ??? Are we supposed to ever get here ? Don't think so. */
- break;
- }
-
- /* SP is actually never part of the saved registers area, so we use the
- corresponding entry in the saved_regs array to manually keep track of
- it's evolution. */
- fs->saved_spr = AS_REG (frame_base) + pv->pdsc$l_size;
-}
-
-/*************************
- * unwind_kernel_handler *
- *************************/
-
-/* Helper for unwind, for the specific case of unwinding through a signal
- handler.
-
- The input frame state describes the kernel frame which has called a signal
- handler. We fill the corresponding saved_regs to have it's "caller" frame
- represented as the interrupted context. */
-
-static void
-unwind_kernel_handler (frame_state_t * fs)
-{
- PDSCDEF * pv = PV_FOR (fs->fp);
-
- CHFDEF1 *sigargs;
- CHFDEF2 *mechargs;
-
- /* Retrieve the arguments passed to the handler, by way of a VMS service
- providing the corresponding "Invocation Context Block". */
- {
- long handler_ivhandle;
- INVO_CONTEXT_BLK handler_ivcb;
-
- CHFCTX *chfctx;
-
- handler_ivcb.libicb$q_ireg [29] = AS_REG (fs->fp);
- handler_ivcb.libicb$q_ireg [30] = 0;
-
- handler_ivhandle = LIB$GET_INVO_HANDLE (&handler_ivcb);
-
- if ((LIB$GET_INVO_CONTEXT (handler_ivhandle, &handler_ivcb) & 1) != 1)
- return;
-
- chfctx = (CHFCTX *) AS_ADDR (handler_ivcb.libicb$ph_chfctx_addr);
-
- sigargs = (CHFDEF1 *) AS_ADDR (chfctx->chfctx$q_sigarglst);
- mechargs = (CHFDEF2 *) AS_ADDR (chfctx->chfctx$q_mcharglst);
- }
-
- /* Compute the saved return address as the PC of the instruction causing the
- condition, accounting for the fact that it will be adjusted by the next
- call to "unwind" as if it was an actual call return address. */
- {
- /* ABI-6.5.1.1 [Signal Argument Vector]: The signal occurrence address
- is available from the sigargs argument to the handler, designed to
- support both 32 and 64 bit addresses. The initial reference we get
- is a pointer to the 32bit form, from which one may extract a pointer
- to the 64bit version if need be. We work directly from the 32bit
- form here. */
-
- /* The sigargs vector structure for 32bits addresses is:
-
- <......32bit......>
- +-----------------+
- | Vsize | :chf$is_sig_args
- +-----------------+ -+-
- | Condition Value | : [0]
- +-----------------+ :
- | ... | :
- +-----------------+ : vector of Vsize entries
- | Signal PC | :
- +-----------------+ :
- | PS | : [Vsize - 1]
- +-----------------+ -+-
-
- */
-
- unsigned long * sigargs_vector
- = ((unsigned long *) (&sigargs->chf$is_sig_args)) + 1;
-
- long sigargs_vsize
- = sigargs->chf$is_sig_args;
-
- fs->saved_rar = (REG) sigargs_vector [sigargs_vsize - 2] + PC_ADJUST;
- }
-
- fs->saved_spr = RA_UNKNOWN;
- fs->saved_fpr = (REG) mechargs->chf$q_mch_frame;
- fs->saved_pvr = (REG) mechargs->chf$q_mch_savr27;
-
- fs->saved_regs[16] = (REG) mechargs->chf$q_mch_savr16;
- fs->saved_regs[17] = (REG) mechargs->chf$q_mch_savr17;
- fs->saved_regs[18] = (REG) mechargs->chf$q_mch_savr18;
- fs->saved_regs[19] = (REG) mechargs->chf$q_mch_savr19;
- fs->saved_regs[20] = (REG) mechargs->chf$q_mch_savr20;
-}
-
-/* Structure representing a traceback entry in the tracebacks array to be
- filled by __gnat_backtrace below.
-
- !! This should match what is in System.Traceback_Entries, so beware of
- !! the REG/ADDR difference here.
-
- The use of a structure is motivated by the potential necessity of having
- several fields to fill for each entry, for instance if later calls to VMS
- system functions need more than just a mere PC to compute info on a frame
- (e.g. for non-symbolic->symbolic translation purposes). */
-typedef struct {
- ADDR pc; /* Program Counter. */
- ADDR pv; /* Procedure Value. */
-} tb_entry_t;
-
-/********************
- * __gnat_backtrace *
- ********************/
-
-int
-__gnat_backtrace (void **array, int size,
- void *exclude_min, void *exclude_max, int skip_frames)
-{
- int cnt;
-
- tb_entry_t * tbe = (tb_entry_t *)&array [0];
-
- frame_state_t frame_state;
-
- /* Setup the frame state before initiating the unwinding sequence. */
- register REG this_FP __asm__("$29");
- register REG this_SP __asm__("$30");
-
- frame_state.saved_fpr = this_FP;
- frame_state.saved_spr = this_SP;
- frame_state.saved_rar = RA_UNKNOWN;
-
- unwind (&frame_state);
-
- /* At this point frame_state describes this very function. Skip the
- requested number of calls. */
- for (cnt = 0; cnt < skip_frames; cnt ++)
- unwind (&frame_state);
-
- /* Now consider each frame as a potential candidate for insertion inside
- the provided array. */
- cnt = 0;
- while (cnt < size)
- {
- /* Stop if either the frame contents or the unwinder say so. */
- if (STOP_FRAME)
- break;
-
- if (! K_HANDLER_FRAME (&frame_state)
- && (frame_state.pc < exclude_min || frame_state.pc > exclude_max))
- {
- tbe->pc = (ADDR) frame_state.pc;
- tbe->pv = (ADDR) PV_FOR (frame_state.fp);
-
- cnt ++;
- tbe ++;
- }
-
- unwind (&frame_state);
- }
-
- return cnt;
-}
diff --git a/gcc/ada/tb-alvxw.c b/gcc/ada/tb-alvxw.c
deleted file mode 100644
index 4f743a110a7..00000000000
--- a/gcc/ada/tb-alvxw.c
+++ /dev/null
@@ -1,940 +0,0 @@
-/****************************************************************************
- * *
- * GNAT RUN-TIME COMPONENTS *
- * *
- * T R A C E B A C K - A l p h a / V x W o r k s *
- * *
- * C Implementation File *
- * *
- * Copyright (C) 2000-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- *
- * ware Foundation; either version 3, or (at your option) any later ver- *
- * sion. GNAT is distributed in the hope that it will be useful, but WITH- *
- * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
- * or FITNESS FOR A PARTICULAR PURPOSE. *
- * *
- * As a special exception under Section 7 of GPL version 3, you are granted *
- * additional permissions described in the GCC Runtime Library Exception, *
- * version 3.1, as published by the Free Software Foundation. *
- * *
- * You should have received a copy of the GNU General Public License and *
- * a copy of the GCC Runtime Library Exception along with this program; *
- * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see *
- * <http://www.gnu.org/licenses/>. *
- * *
- * GNAT was originally developed by the GNAT team at New York University. *
- * Extensive contributions were provided by Ada Core Technologies Inc. *
- * *
- ****************************************************************************/
-
-/* Alpha vxWorks requires a special, complex treatment that is extracted
- from GDB. This file is #included within tracebak.c in the appropriate
- case. */
-
-#include <stddef.h>
-#include <stdlib.h>
-#include <limits.h>
-#include <string.h>
-
-extern void kerTaskEntry(void);
-
-/* We still use a number of macros similar to the ones for the generic
- __gnat_backtrace implementation. */
-#define SKIP_FRAME 1
-#define PC_ADJUST -4
-
-#define STOP_FRAME \
- (current == NULL \
- || ((CORE_ADDR) &kerTaskEntry >= PROC_LOW_ADDR (current->proc_desc) \
- && current->pc >= (CORE_ADDR) &kerTaskEntry))
-
-/* Register numbers of various important registers.
- Note that most of these values are "real" register numbers,
- and correspond to the general registers of the machine,
- and FP_REGNUM is a "phony" register number which is too large
- to be an actual register number as far as the user is concerned
- but serves to get the desired value when passed to read_register. */
-
-#define T7_REGNUM 8 /* Return address register for OSF/1 __add* */
-#define GCC_FP_REGNUM 15 /* Used by gcc as frame register */
-#define T9_REGNUM 23 /* Return address register for OSF/1 __div* */
-#define SP_REGNUM 30 /* Contains address of top of stack */
-#define RA_REGNUM 26 /* Contains return address value */
-#define FP0_REGNUM 32 /* Floating point register 0 */
-#define PC_REGNUM 64 /* Contains program counter */
-#define NUM_REGS 66
-
-#define VM_MIN_ADDRESS (CORE_ADDR)0x120000000
-
-#define SIZEOF_FRAME_SAVED_REGS (sizeof (CORE_ADDR) * (NUM_REGS))
-#define INIT_EXTRA_FRAME_INFO(fromleaf, fci) init_extra_frame_info(fci)
-
-#define FRAME_CHAIN(thisframe) (CORE_ADDR) alpha_frame_chain (thisframe)
-
-#define FRAME_CHAIN_VALID(CHAIN, THISFRAME) \
- ((CHAIN) != 0 \
- && !inside_entry_file (FRAME_SAVED_PC (THISFRAME)))
-
-#define FRAME_SAVED_PC(FRAME) (alpha_frame_saved_pc (FRAME))
-
-#define FRAME_CHAIN_COMBINE(CHAIN, THISFRAME) (CHAIN)
-
-#define INIT_FRAME_PC(FROMLEAF, PREV)
-
-#define INIT_FRAME_PC_FIRST(FROMLEAF, PREV) \
- (PREV)->pc = ((FROMLEAF) ? SAVED_PC_AFTER_CALL ((PREV)->next) \
- : (PREV)->next ? FRAME_SAVED_PC ((PREV)->next) : read_pc ());
-
-#define SAVED_PC_AFTER_CALL(FRAME) alpha_saved_pc_after_call (FRAME)
-
-typedef unsigned long long int bfd_vma;
-
-typedef bfd_vma CORE_ADDR;
-
-typedef struct pdr
-{
- bfd_vma adr; /* memory address of start of procedure */
- long isym; /* start of local symbol entries */
- long iline; /* start of line number entries*/
- long regmask; /* save register mask */
- long regoffset; /* save register offset */
- long iopt; /* start of optimization symbol entries*/
- long fregmask; /* save floating point register mask */
- long fregoffset; /* save floating point register offset */
- long frameoffset; /* frame size */
- short framereg; /* frame pointer register */
- short pcreg; /* offset or reg of return pc */
- long lnLow; /* lowest line in the procedure */
- long lnHigh; /* highest line in the procedure */
- bfd_vma cbLineOffset; /* byte offset for this procedure from the fd base */
- /* These fields are new for 64 bit ECOFF. */
- unsigned gp_prologue : 8; /* byte size of GP prologue */
- unsigned gp_used : 1; /* true if the procedure uses GP */
- unsigned reg_frame : 1; /* true if register frame procedure */
- unsigned prof : 1; /* true if compiled with -pg */
- unsigned reserved : 13; /* reserved: must be zero */
- unsigned localoff : 8; /* offset of local variables from vfp */
-} PDR;
-
-typedef struct alpha_extra_func_info
-{
- long numargs; /* number of args to procedure (was iopt) */
- PDR pdr; /* Procedure descriptor record */
-}
-*alpha_extra_func_info_t;
-
-struct frame_info
-{
- /* Nominal address of the frame described. See comments at FRAME_FP
- about what this means outside the *FRAME* macros; in the *FRAME*
- macros, it can mean whatever makes most sense for this machine. */
- CORE_ADDR frame;
-
- /* Address at which execution is occurring in this frame. For the
- innermost frame, it's the current pc. For other frames, it is a
- pc saved in the next frame. */
- CORE_ADDR pc;
-
- /* For each register, address of where it was saved on entry to the
- frame, or zero if it was not saved on entry to this frame. This
- includes special registers such as pc and fp saved in special
- ways in the stack frame. The SP_REGNUM is even more special, the
- address here is the sp for the next frame, not the address where
- the sp was saved. Allocated by frame_saved_regs_zalloc () which
- is called and initialized by FRAME_INIT_SAVED_REGS. */
- CORE_ADDR *saved_regs; /*NUM_REGS */
-
- int localoff;
- int pc_reg;
- alpha_extra_func_info_t proc_desc;
-
- /* Pointers to the next and previous frame_info's in the frame cache. */
- struct frame_info *next, *prev;
-};
-
-struct frame_saved_regs
-{
- /* For each register R (except the SP), regs[R] is the address at
- which it was saved on entry to the frame, or zero if it was not
- saved on entry to this frame. This includes special registers
- such as pc and fp saved in special ways in the stack frame.
-
- regs[SP_REGNUM] is different. It holds the actual SP, not the
- address at which it was saved. */
-
- CORE_ADDR regs[NUM_REGS];
-};
-
-static CORE_ADDR theRegisters[32];
-
-/* Prototypes for local functions. */
-
-static CORE_ADDR read_next_frame_reg (struct frame_info *, int);
-static CORE_ADDR heuristic_proc_start (CORE_ADDR);
-static int alpha_about_to_return (CORE_ADDR pc);
-static void init_extra_frame_info (struct frame_info *);
-static CORE_ADDR alpha_frame_chain (struct frame_info *);
-static CORE_ADDR alpha_frame_saved_pc (struct frame_info *frame);
-static void *trace_alloc (unsigned int);
-static struct frame_info *create_new_frame (CORE_ADDR, CORE_ADDR);
-
-static alpha_extra_func_info_t
-heuristic_proc_desc (CORE_ADDR, CORE_ADDR, struct frame_info *,
- struct frame_saved_regs *);
-
-static alpha_extra_func_info_t
-find_proc_desc (CORE_ADDR, struct frame_info *, struct frame_saved_regs *);
-
-/* Heuristic_proc_start may hunt through the text section for a long
- time across a 2400 baud serial line. Allows the user to limit this
- search. */
-static unsigned int heuristic_fence_post = 1<<16;
-
-/* Layout of a stack frame on the alpha:
-
- | |
- pdr members: | 7th ... nth arg, |
- | `pushed' by caller. |
- | |
-----------------|-------------------------------|<-- old_sp == vfp
- ^ ^ ^ ^ | |
- | | | | | |
- | |localoff | Copies of 1st .. 6th |
- | | | | | argument if necessary. |
- | | | v | |
- | | | --- |-------------------------------|<-- FRAME_LOCALS_ADDRESS
- | | | | |
- | | | | Locals and temporaries. |
- | | | | |
- | | | |-------------------------------|
- | | | | |
- |-fregoffset | Saved float registers. |
- | | | | F9 |
- | | | | . |
- | | | | . |
- | | | | F2 |
- | | v | |
- | | -------|-------------------------------|
- | | | |
- | | | Saved registers. |
- | | | S6 |
- |-regoffset | . |
- | | | . |
- | | | S0 |
- | | | pdr.pcreg |
- | v | |
- | ----------|-------------------------------|
- | | |
- frameoffset | Argument build area, gets |
- | | 7th ... nth arg for any |
- | | called procedure. |
- v | |
- -------------|-------------------------------|<-- sp
- | | */
-
-#define PROC_LOW_ADDR(PROC) ((PROC)->pdr.adr) /* least address */
-#define PROC_HIGH_ADDR(PROC) ((PROC)->pdr.iline) /* upper address bound */
-#define PROC_DUMMY_FRAME(PROC) ((PROC)->pdr.cbLineOffset) /*CALL_DUMMY frame */
-#define PROC_FRAME_OFFSET(PROC) ((PROC)->pdr.frameoffset)
-#define PROC_FRAME_REG(PROC) ((PROC)->pdr.framereg)
-#define PROC_REG_MASK(PROC) ((PROC)->pdr.regmask)
-#define PROC_FREG_MASK(PROC) ((PROC)->pdr.fregmask)
-#define PROC_REG_OFFSET(PROC) ((PROC)->pdr.regoffset)
-#define PROC_FREG_OFFSET(PROC) ((PROC)->pdr.fregoffset)
-#define PROC_PC_REG(PROC) ((PROC)->pdr.pcreg)
-#define PROC_LOCALOFF(PROC) ((PROC)->pdr.localoff)
-
-/* Local storage allocation/deallocation functions. trace_alloc does
- a malloc, but also chains allocated blocks on trace_alloc_chain, so
- they may all be freed on exit from __gnat_backtrace. */
-
-struct alloc_chain
-{
- struct alloc_chain *next;
- double x[0];
-};
-struct alloc_chain *trace_alloc_chain;
-
-static void *
-trace_alloc (unsigned int n)
-{
- struct alloc_chain * result = malloc (n + sizeof(struct alloc_chain));
-
- result->next = trace_alloc_chain;
- trace_alloc_chain = result;
- return (void*) result->x;
-}
-
-static void
-free_trace_alloc (void)
-{
- while (trace_alloc_chain != 0)
- {
- struct alloc_chain *old = trace_alloc_chain;
-
- trace_alloc_chain = trace_alloc_chain->next;
- free (old);
- }
-}
-
-/* Read value at ADDR into *DEST, returning 0 if this is valid, != 0
- otherwise. */
-
-static int
-read_memory_safe4 (CORE_ADDR addr, unsigned int *dest)
-{
- *dest = *((unsigned int*) addr);
- return 0;
-}
-
-/* Read value at ADDR into *DEST, returning 0 if this is valid, != 0
- otherwise. */
-
-static int
-read_memory_safe8 (CORE_ADDR addr, CORE_ADDR *dest)
-{
- *dest = *((CORE_ADDR*) addr);
- return 0;
-}
-
-static CORE_ADDR
-read_register (int regno)
-{
- if (regno >= 0 && regno < 31)
- return theRegisters[regno];
-
- return (CORE_ADDR) 0;
-}
-
-static void
-frame_saved_regs_zalloc (struct frame_info *fi)
-{
- fi->saved_regs = (CORE_ADDR *) trace_alloc (SIZEOF_FRAME_SAVED_REGS);
- memset (fi->saved_regs, 0, SIZEOF_FRAME_SAVED_REGS);
-}
-
-static void *
-frame_obstack_alloc (unsigned long size)
-{
- return (void *) trace_alloc (size);
-}
-
-static int
-inside_entry_file (CORE_ADDR addr)
-{
- if (addr == 0)
- return 1;
- else
- return 0;
-}
-
-static CORE_ADDR
-alpha_saved_pc_after_call (struct frame_info *frame)
-{
- CORE_ADDR pc = frame->pc;
- alpha_extra_func_info_t proc_desc;
- int pcreg;
-
- proc_desc = find_proc_desc (pc, frame->next, NULL);
- pcreg = proc_desc ? PROC_PC_REG (proc_desc) : RA_REGNUM;
-
- return read_register (pcreg);
-}
-
-/* Guaranteed to set frame->saved_regs to some values (it never leaves it
- NULL). */
-
-static void
-alpha_find_saved_regs (struct frame_info *frame)
-{
- int ireg;
- CORE_ADDR reg_position;
- unsigned long mask;
- alpha_extra_func_info_t proc_desc;
- int returnreg;
-
- frame_saved_regs_zalloc (frame);
-
- /* If it is the frame for __sigtramp, the saved registers are located in a
- sigcontext structure somewhere on the stack. __sigtramp passes a pointer
- to the sigcontext structure on the stack. If the stack layout for
- __sigtramp changes, or if sigcontext offsets change, we might have to
- update this code. */
-
-#ifndef SIGFRAME_PC_OFF
-#define SIGFRAME_PC_OFF (2 * 8)
-#define SIGFRAME_REGSAVE_OFF (4 * 8)
-#define SIGFRAME_FPREGSAVE_OFF (SIGFRAME_REGSAVE_OFF + 32 * 8 + 8)
-#endif
-
- proc_desc = frame->proc_desc;
- if (proc_desc == NULL)
- /* I'm not sure how/whether this can happen. Normally when we can't
- find a proc_desc, we "synthesize" one using heuristic_proc_desc
- and set the saved_regs right away. */
- return;
-
- /* Fill in the offsets for the registers which gen_mask says
- were saved. */
-
- reg_position = frame->frame + PROC_REG_OFFSET (proc_desc);
- mask = PROC_REG_MASK (proc_desc);
-
- returnreg = PROC_PC_REG (proc_desc);
-
- /* Note that RA is always saved first, regardless of its actual
- register number. */
- if (mask & (1 << returnreg))
- {
- frame->saved_regs[returnreg] = reg_position;
- reg_position += 8;
- mask &= ~(1 << returnreg); /* Clear bit for RA so we
- don't save again later. */
- }
-
- for (ireg = 0; ireg <= 31; ireg++)
- if (mask & (1 << ireg))
- {
- frame->saved_regs[ireg] = reg_position;
- reg_position += 8;
- }
-
- /* Fill in the offsets for the registers which float_mask says
- were saved. */
-
- reg_position = frame->frame + PROC_FREG_OFFSET (proc_desc);
- mask = PROC_FREG_MASK (proc_desc);
-
- for (ireg = 0; ireg <= 31; ireg++)
- if (mask & (1 << ireg))
- {
- frame->saved_regs[FP0_REGNUM + ireg] = reg_position;
- reg_position += 8;
- }
-
- frame->saved_regs[PC_REGNUM] = frame->saved_regs[returnreg];
-}
-
-static CORE_ADDR
-read_next_frame_reg (struct frame_info *fi, int regno)
-{
- CORE_ADDR result;
- for (; fi; fi = fi->next)
- {
- /* We have to get the saved sp from the sigcontext
- if it is a signal handler frame. */
- if (regno == SP_REGNUM)
- return fi->frame;
- else
- {
- if (fi->saved_regs == 0)
- alpha_find_saved_regs (fi);
-
- if (fi->saved_regs[regno])
- {
- if (read_memory_safe8 (fi->saved_regs[regno], &result) == 0)
- return result;
- else
- return 0;
- }
- }
- }
-
- return read_register (regno);
-}
-
-static CORE_ADDR
-alpha_frame_saved_pc (struct frame_info *frame)
-{
- return read_next_frame_reg (frame, frame->pc_reg);
-}
-
-static struct alpha_extra_func_info temp_proc_desc;
-
-/* Nonzero if instruction at PC is a return instruction. "ret
- $zero,($ra),1" on alpha. */
-
-static int
-alpha_about_to_return (CORE_ADDR pc)
-{
- int inst;
-
- read_memory_safe4 (pc, &inst);
- return inst == 0x6bfa8001;
-}
-
-/* A heuristically computed start address for the subprogram
- containing address PC. Returns 0 if none detected. */
-
-static CORE_ADDR
-heuristic_proc_start (CORE_ADDR pc)
-{
- CORE_ADDR start_pc = pc;
- CORE_ADDR fence = start_pc - heuristic_fence_post;
-
- if (start_pc == 0)
- return 0;
-
- if (heuristic_fence_post == UINT_MAX
- || fence < VM_MIN_ADDRESS)
- fence = VM_MIN_ADDRESS;
-
- /* search back for previous return */
- for (start_pc -= 4; ; start_pc -= 4)
- {
- if (start_pc < fence)
- return 0;
- else if (alpha_about_to_return (start_pc))
- break;
- }
-
- start_pc += 4; /* skip return */
- return start_pc;
-}
-
-static alpha_extra_func_info_t
-heuristic_proc_desc (CORE_ADDR start_pc,
- CORE_ADDR limit_pc,
- struct frame_info *next_frame,
- struct frame_saved_regs *saved_regs_p)
-{
- CORE_ADDR sp = read_next_frame_reg (next_frame, SP_REGNUM);
- CORE_ADDR cur_pc;
- int frame_size;
- int has_frame_reg = 0;
- unsigned long reg_mask = 0;
- int pcreg = -1;
-
- if (start_pc == 0)
- return 0;
-
- memset (&temp_proc_desc, '\0', sizeof (temp_proc_desc));
- if (saved_regs_p != 0)
- memset (saved_regs_p, '\0', sizeof (struct frame_saved_regs));
-
- PROC_LOW_ADDR (&temp_proc_desc) = start_pc;
-
- if (start_pc + 200 < limit_pc)
- limit_pc = start_pc + 200;
-
- frame_size = 0;
- for (cur_pc = start_pc; cur_pc < limit_pc; cur_pc += 4)
- {
- unsigned int word;
- int status;
-
- status = read_memory_safe4 (cur_pc, &word);
- if (status)
- return 0;
-
- if ((word & 0xffff0000) == 0x23de0000) /* lda $sp,n($sp) */
- {
- if (word & 0x8000)
- frame_size += (-word) & 0xffff;
- else
- /* Exit loop if a positive stack adjustment is found, which
- usually means that the stack cleanup code in the function
- epilogue is reached. */
- break;
- }
- else if ((word & 0xfc1f0000) == 0xb41e0000 /* stq reg,n($sp) */
- && (word & 0xffff0000) != 0xb7fe0000) /* reg != $zero */
- {
- int reg = (word & 0x03e00000) >> 21;
-
- reg_mask |= 1 << reg;
- if (saved_regs_p != 0)
- saved_regs_p->regs[reg] = sp + (short) word;
-
- /* Starting with OSF/1-3.2C, the system libraries are shipped
- without local symbols, but they still contain procedure
- descriptors without a symbol reference. GDB is currently
- unable to find these procedure descriptors and uses
- heuristic_proc_desc instead.
- As some low level compiler support routines (__div*, __add*)
- use a non-standard return address register, we have to
- add some heuristics to determine the return address register,
- or stepping over these routines will fail.
- Usually the return address register is the first register
- saved on the stack, but assembler optimization might
- rearrange the register saves.
- So we recognize only a few registers (t7, t9, ra) within
- the procedure prologue as valid return address registers.
- If we encounter a return instruction, we extract the
- return address register from it.
-
- FIXME: Rewriting GDB to access the procedure descriptors,
- e.g. via the minimal symbol table, might obviate this hack. */
- if (pcreg == -1
- && cur_pc < (start_pc + 80)
- && (reg == T7_REGNUM || reg == T9_REGNUM || reg == RA_REGNUM))
- pcreg = reg;
- }
- else if ((word & 0xffe0ffff) == 0x6be08001) /* ret zero,reg,1 */
- pcreg = (word >> 16) & 0x1f;
- else if (word == 0x47de040f) /* bis sp,sp fp */
- has_frame_reg = 1;
- }
-
- if (pcreg == -1)
- {
- /* If we haven't found a valid return address register yet,
- keep searching in the procedure prologue. */
- while (cur_pc < (limit_pc + 80) && cur_pc < (start_pc + 80))
- {
- unsigned int word;
-
- if (read_memory_safe4 (cur_pc, &word))
- break;
- cur_pc += 4;
-
- if ((word & 0xfc1f0000) == 0xb41e0000 /* stq reg,n($sp) */
- && (word & 0xffff0000) != 0xb7fe0000) /* reg != $zero */
- {
- int reg = (word & 0x03e00000) >> 21;
-
- if (reg == T7_REGNUM || reg == T9_REGNUM || reg == RA_REGNUM)
- {
- pcreg = reg;
- break;
- }
- }
- else if ((word & 0xffe0ffff) == 0x6be08001) /* ret zero,reg,1 */
- {
- pcreg = (word >> 16) & 0x1f;
- break;
- }
- }
- }
-
- if (has_frame_reg)
- PROC_FRAME_REG (&temp_proc_desc) = GCC_FP_REGNUM;
- else
- PROC_FRAME_REG (&temp_proc_desc) = SP_REGNUM;
-
- PROC_FRAME_OFFSET (&temp_proc_desc) = frame_size;
- PROC_REG_MASK (&temp_proc_desc) = reg_mask;
- PROC_PC_REG (&temp_proc_desc) = (pcreg == -1) ? RA_REGNUM : pcreg;
- PROC_LOCALOFF (&temp_proc_desc) = 0; /* XXX - bogus */
-
- return &temp_proc_desc;
-}
-
-static alpha_extra_func_info_t
-find_proc_desc (CORE_ADDR pc,
- struct frame_info *next_frame,
- struct frame_saved_regs *saved_regs)
-{
- CORE_ADDR startaddr;
-
- /* If heuristic_fence_post is nonzero, determine the procedure
- start address by examining the instructions.
- This allows us to find the start address of static functions which
- have no symbolic information, as startaddr would have been set to
- the preceding global function start address by the
- find_pc_partial_function call above. */
- startaddr = heuristic_proc_start (pc);
-
- return heuristic_proc_desc (startaddr, pc, next_frame, saved_regs);
-}
-
-static CORE_ADDR
-alpha_frame_chain (struct frame_info *frame)
-{
- alpha_extra_func_info_t proc_desc;
- CORE_ADDR saved_pc = FRAME_SAVED_PC (frame);
-
- if (saved_pc == 0 || inside_entry_file (saved_pc))
- return 0;
-
- proc_desc = find_proc_desc (saved_pc, frame, NULL);
- if (!proc_desc)
- return 0;
-
- /* If no frame pointer and frame size is zero, we must be at end
- of stack (or otherwise hosed). If we don't check frame size,
- we loop forever if we see a zero size frame. */
- if (PROC_FRAME_REG (proc_desc) == SP_REGNUM
- && PROC_FRAME_OFFSET (proc_desc) == 0)
- return 0;
- else
- return read_next_frame_reg (frame, PROC_FRAME_REG (proc_desc))
- + PROC_FRAME_OFFSET (proc_desc);
-}
-
-static void
-init_extra_frame_info (struct frame_info *frame)
-{
- struct frame_saved_regs temp_saved_regs;
- alpha_extra_func_info_t proc_desc =
- find_proc_desc (frame->pc, frame->next, &temp_saved_regs);
-
- frame->saved_regs = NULL;
- frame->localoff = 0;
- frame->pc_reg = RA_REGNUM;
- frame->proc_desc = proc_desc;
-
- if (proc_desc)
- {
- /* Get the locals offset and the saved pc register from the
- procedure descriptor, they are valid even if we are in the
- middle of the prologue. */
- frame->localoff = PROC_LOCALOFF (proc_desc);
- frame->pc_reg = PROC_PC_REG (proc_desc);
-
- /* Fixup frame-pointer - only needed for top frame */
-
- /* This may not be quite right, if proc has a real frame register.
- Get the value of the frame relative sp, procedure might have been
- interrupted by a signal at it's very start. */
- if (frame->pc == PROC_LOW_ADDR (proc_desc))
- frame->frame = read_next_frame_reg (frame->next, SP_REGNUM);
- else
- frame->frame
- = (read_next_frame_reg (frame->next, PROC_FRAME_REG (proc_desc))
- + PROC_FRAME_OFFSET (proc_desc));
-
- frame->saved_regs
- = (CORE_ADDR *) frame_obstack_alloc (SIZEOF_FRAME_SAVED_REGS);
- memcpy
- (frame->saved_regs, temp_saved_regs.regs, SIZEOF_FRAME_SAVED_REGS);
- frame->saved_regs[PC_REGNUM] = frame->saved_regs[RA_REGNUM];
- }
-}
-
-/* Create an arbitrary (i.e. address specified by user) or innermost frame.
- Always returns a non-NULL value. */
-
-static struct frame_info *
-create_new_frame (CORE_ADDR addr, CORE_ADDR pc)
-{
- struct frame_info *fi;
-
- fi = (struct frame_info *)
- trace_alloc (sizeof (struct frame_info));
-
- /* Arbitrary frame */
- fi->next = NULL;
- fi->prev = NULL;
- fi->frame = addr;
- fi->pc = pc;
-
-#ifdef INIT_EXTRA_FRAME_INFO
- INIT_EXTRA_FRAME_INFO (0, fi);
-#endif
-
- return fi;
-}
-
-static CORE_ADDR current_pc;
-
-static void
-set_current_pc (void)
-{
- current_pc = (CORE_ADDR) __builtin_return_address (0);
-}
-
-static CORE_ADDR
-read_pc (void)
-{
- return current_pc;
-}
-
-static struct frame_info *
-get_current_frame (void)
-{
- return create_new_frame (0, read_pc ());
-}
-
-/* Return the frame that called FI.
- If FI is the original frame (it has no caller), return 0. */
-
-static struct frame_info *
-get_prev_frame (struct frame_info *next_frame)
-{
- CORE_ADDR address = 0;
- struct frame_info *prev;
- int fromleaf = 0;
-
- /* If we have the prev one, return it */
- if (next_frame->prev)
- return next_frame->prev;
-
- /* On some machines it is possible to call a function without
- setting up a stack frame for it. On these machines, we
- define this macro to take two args; a frameinfo pointer
- identifying a frame and a variable to set or clear if it is
- or isn't leafless. */
-
- /* Two macros defined in tm.h specify the machine-dependent
- actions to be performed here.
-
- First, get the frame's chain-pointer. If that is zero, the frame
- is the outermost frame or a leaf called by the outermost frame.
- This means that if start calls main without a frame, we'll return
- 0 (which is fine anyway).
-
- Nope; there's a problem. This also returns when the current
- routine is a leaf of main. This is unacceptable. We move
- this to after the ffi test; I'd rather have backtraces from
- start go curfluy than have an abort called from main not show
- main. */
-
- address = FRAME_CHAIN (next_frame);
- if (!FRAME_CHAIN_VALID (address, next_frame))
- return 0;
- address = FRAME_CHAIN_COMBINE (address, next_frame);
-
- if (address == 0)
- return 0;
-
- prev = (struct frame_info *) trace_alloc (sizeof (struct frame_info));
-
- prev->saved_regs = NULL;
- if (next_frame)
- next_frame->prev = prev;
-
- prev->next = next_frame;
- prev->prev = (struct frame_info *) 0;
- prev->frame = address;
-
- /* This change should not be needed, FIXME! We should
- determine whether any targets *need* INIT_FRAME_PC to happen
- after INIT_EXTRA_FRAME_INFO and come up with a simple way to
- express what goes on here.
-
- INIT_EXTRA_FRAME_INFO is called from two places: create_new_frame
- (where the PC is already set up) and here (where it isn't).
- INIT_FRAME_PC is only called from here, always after
- INIT_EXTRA_FRAME_INFO.
-
- The catch is the MIPS, where INIT_EXTRA_FRAME_INFO requires the PC
- value (which hasn't been set yet). Some other machines appear to
- require INIT_EXTRA_FRAME_INFO before they can do INIT_FRAME_PC. Phoo.
-
- We shouldn't need INIT_FRAME_PC_FIRST to add more complication to
- an already overcomplicated part of GDB. gnu@cygnus.com, 15Sep92.
-
- Assuming that some machines need INIT_FRAME_PC after
- INIT_EXTRA_FRAME_INFO, one possible scheme:
-
- SETUP_INNERMOST_FRAME()
- Default version is just create_new_frame (read_fp ()),
- read_pc ()). Machines with extra frame info would do that (or the
- local equivalent) and then set the extra fields.
- INIT_PREV_FRAME(fromleaf, prev)
- Replace INIT_EXTRA_FRAME_INFO and INIT_FRAME_PC. This should
- also return a flag saying whether to keep the new frame, or
- whether to discard it, because on some machines (e.g. mips) it
- is really awkward to have FRAME_CHAIN_VALID called *before*
- INIT_EXTRA_FRAME_INFO (there is no good way to get information
- deduced in FRAME_CHAIN_VALID into the extra fields of the new frame).
- std_frame_pc(fromleaf, prev)
- This is the default setting for INIT_PREV_FRAME. It just does what
- the default INIT_FRAME_PC does. Some machines will call it from
- INIT_PREV_FRAME (either at the beginning, the end, or in the middle).
- Some machines won't use it.
- kingdon@cygnus.com, 13Apr93, 31Jan94, 14Dec94. */
-
-#ifdef INIT_FRAME_PC_FIRST
- INIT_FRAME_PC_FIRST (fromleaf, prev);
-#endif
-
-#ifdef INIT_EXTRA_FRAME_INFO
- INIT_EXTRA_FRAME_INFO (fromleaf, prev);
-#endif
-
- /* This entry is in the frame queue now, which is good since
- FRAME_SAVED_PC may use that queue to figure out its value
- (see tm-sparc.h). We want the pc saved in the inferior frame. */
- INIT_FRAME_PC (fromleaf, prev);
-
- /* If ->frame and ->pc are unchanged, we are in the process of getting
- ourselves into an infinite backtrace. Some architectures check this
- in FRAME_CHAIN or thereabouts, but it seems like there is no reason
- this can't be an architecture-independent check. */
- if (next_frame != NULL)
- {
- if (prev->frame == next_frame->frame
- && prev->pc == next_frame->pc)
- {
- next_frame->prev = NULL;
- free (prev);
- return NULL;
- }
- }
-
- return prev;
-}
-
-#define SAVE(regno,disp) \
- "stq $" #regno ", " #disp "(%0)\n"
-
-int
-__gnat_backtrace (void **array,
- int size,
- void *exclude_min,
- void *exclude_max,
- int skip_frames)
-{
- struct frame_info* top;
- struct frame_info* current;
- int cnt;
-
- /* This function is not thread safe, protect it */
- (*Lock_Task) ();
- asm volatile (
- SAVE (9,72)
- SAVE (10,80)
- SAVE (11,88)
- SAVE (12,96)
- SAVE (13,104)
- SAVE (14,112)
- SAVE (15,120)
- SAVE (16,128)
- SAVE (17,136)
- SAVE (18,144)
- SAVE (19,152)
- SAVE (20,160)
- SAVE (21,168)
- SAVE (22,176)
- SAVE (23,184)
- SAVE (24,192)
- SAVE (25,200)
- SAVE (26,208)
- SAVE (27,216)
- SAVE (28,224)
- SAVE (29,232)
- SAVE (30,240)
- : : "r" (&theRegisters));
-
- trace_alloc_chain = NULL;
- set_current_pc ();
-
- top = current = get_current_frame ();
- cnt = 0;
-
- for (cnt = 0; cnt < skip_frames; cnt += 1) {
- current = get_prev_frame (current);
- }
-
- cnt = 0;
- while (cnt < size)
- {
- if (STOP_FRAME)
- break;
-
- if (current->pc < (CORE_ADDR) exclude_min
- || current->pc > (CORE_ADDR) exclude_max)
- array[cnt++] = (void*) (current->pc + PC_ADJUST);
-
- current = get_prev_frame (current);
- }
-
- free_trace_alloc ();
- (*Unlock_Task) ();
-
- return cnt;
-}
diff --git a/gcc/ada/tb-ivms.c b/gcc/ada/tb-ivms.c
deleted file mode 100644
index 3d55c6e8627..00000000000
--- a/gcc/ada/tb-ivms.c
+++ /dev/null
@@ -1,88 +0,0 @@
-/****************************************************************************
- * *
- * GNAT RUN-TIME COMPONENTS *
- * *
- * T R A C E B A C K - I t a n i u m / V M S *
- * *
- * C Implementation File *
- * *
- * Copyright (C) 2007-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- *
- * ware Foundation; either version 3, or (at your option) any later ver- *
- * sion. GNAT is distributed in the hope that it will be useful, but WITH- *
- * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
- * or FITNESS FOR A PARTICULAR PURPOSE. *
- * *
- * As a special exception under Section 7 of GPL version 3, you are granted *
- * additional permissions described in the GCC Runtime Library Exception, *
- * version 3.1, as published by the Free Software Foundation. *
- * *
- * You should have received a copy of the GNU General Public License and *
- * a copy of the GCC Runtime Library Exception along with this program; *
- * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see *
- * <http://www.gnu.org/licenses/>. *
- * *
- * GNAT was originally developed by the GNAT team at New York University. *
- * Extensive contributions were provided by Ada Core Technologies Inc. *
- * *
- ****************************************************************************/
-
-/* Itanium Open/VMS implementation of backtrace. Use ICB (Invocation
- Context Block) routines. */
-#include <stdlib.h>
-#include <vms/libicb.h>
-
-/* Declare libicb routines. */
-extern INVO_CONTEXT_BLK *LIB$I64_CREATE_INVO_CONTEXT (void *(*)(size_t),
- void (*)(void *),
- int);
-extern void LIB$I64_FREE_INVO_CONTEXT (INVO_CONTEXT_BLK *);
-extern int LIB$I64_GET_CURR_INVO_CONTEXT(INVO_CONTEXT_BLK *);
-extern int LIB$I64_GET_PREV_INVO_CONTEXT(INVO_CONTEXT_BLK *);
-
-/* Gcc internal headers poison malloc. So use xmalloc() when building the
- compiler. */
-#ifdef IN_RTS
-#define BT_MALLOC malloc
-#else
-#define BT_MALLOC xmalloc
-#endif
-
-int
-__gnat_backtrace (void **array, int size,
- void *exclude_min, void *exclude_max, int skip_frames)
-{
- INVO_CONTEXT_BLK *ctxt;
- int res = 0;
- int n = 0;
-
- /* Create the context. */
- ctxt = LIB$I64_CREATE_INVO_CONTEXT (BT_MALLOC, free, 0);
- if (ctxt == NULL)
- return 0;
-
- LIB$I64_GET_CURR_INVO_CONTEXT (ctxt);
-
- while (1)
- {
- void *pc = (void *)ctxt->libicb$ih_pc;
- if (pc == (void *)0)
- break;
- if (ctxt->libicb$v_bottom_of_stack)
- break;
- if (n >= skip_frames && (pc < exclude_min || pc > exclude_max))
- {
- array[res++] = (void *)(ctxt->libicb$ih_pc);
- if (res == size)
- break;
- }
- n++;
- LIB$I64_GET_PREV_INVO_CONTEXT (ctxt);
- }
-
- /* Free the context. */
- LIB$I64_FREE_INVO_CONTEXT (ctxt);
- return res;
-}
diff --git a/gcc/ada/tracebak.c b/gcc/ada/tracebak.c
index 4efb75e61f1..54ec90f674b 100644
--- a/gcc/ada/tracebak.c
+++ b/gcc/ada/tracebak.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 2000-2012, Free Software Foundation, Inc. *
+ * Copyright (C) 2000-2014, Free Software Foundation, Inc. *
* *
* 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- *
@@ -95,19 +95,7 @@ extern void (*Unlock_Task) (void);
*-- Target specific implementations --*
*-------------------------------------*/
-#if defined (__alpha_vxworks)
-
-#include "tb-alvxw.c"
-
-#elif defined (__ALPHA) && defined (__VMS__)
-
-#include "tb-alvms.c"
-
-#elif defined (__ia64__) && defined (__VMS__)
-
-#include "tb-ivms.c"
-
-#elif defined (_WIN64) && defined (__SEH__)
+#if defined (_WIN64) && defined (__SEH__)
#include <windows.h>
View Lorry Controller Status