From e8374e7af37c56a79c8d28b0f7367bcc5a4d6707 Mon Sep 17 00:00:00 2001
From: Arnaud Charlet <charlet@gcc.gnu.org>
Date: Tue, 2 Aug 2011 16:50:56 +0200
Subject: [PATCH] [multiple changes]
2011-08-02 Robert Dewar <dewar@adacore.com>
* sem_res.adb: Minor reformatting.
* sem_prag.adb: Minor reformatting.
2011-08-02 Javier Miranda <miranda@adacore.com>
* exp_atag.adb, exp_atags.ads
(Build_Common_Dispatching_Select_Statement): Replace argument DT_Ptr
by the tagged type Entity. Required to use this routine in the VM
targets since we do not have available the Tag entity in the VM
platforms.
* exp_ch6.adb
(Expand_N_Subprogram_Body): Do not invoke Build_VM_TSDs if package
Ada.Tags has not been previously loaded.
* exp_ch7.adb
(Expand_N_Package_Declaration, Expand_N_Package_Body): Do not invoke
Build_VM_TSDs if package Ada.Tags has not been previously loaded.
* sem_aux.adb
(Enclosing_Dynamic_Scope): Add missing support to handle the full
view of enclosing scopes. Required to handle enclosing scopes that
are synchronized types whose full view is a task type.
* exp_disp.adb
(Build_VM_TSDs): Minor code improvement to avoid generating and
analyzing lists with empty nodes.
(Make_Disp_Asynchronous_Select_Body): Add support for VM targets.
(Make_Disp_Conditional_Select_Body): Add support for VM targets.
(Make_Disp_Get_Prim_Op_Kind): Add support for VM targets.
(Make_Disp_Timed_Select_Body): Add support for VM targets.
(Make_Select_Specific_Data_Table): Add support for VM targets.
(Make_VM_TSD): Generate code to initialize the SSD structure of
the TSD.
2011-08-02 Yannick Moy <moy@adacore.com>
* lib-writ.adb (Write_ALI): when ALFA mode is set, write local
cross-references section in ALI.
* lib-xref.adb, lib-xref.ads (Xref_Entry): add components Sub
(enclosing subprogram), Slc (location of Sub) and Sun (unit number of
Sub).
(Enclosing_Subprogram_Or_Package): new function to return the enclosing
subprogram or package entity of a node
(Is_Local_Reference_Type): new function returns True for references
selected in local cross-references.
(Lt): function extracted from Lt in Output_References
(Write_Entity_Name): function extracted from Output_References
(Generate_Definition): generate reference with type 'D' for definition
of objects (object declaration and parameter specification), with
appropriate locations and units, for use in local cross-references.
(Generate_Reference): update fields Sub, Slc and Sun. Keep newly created
references of type 'I' for initialization in object definition.
(Output_References): move part of function Lt and procedure
Write_Entity_Name outside of the body. Ignore references of types 'D'
and 'I' introduced for local cross-references.
(Output_Local_References): new procedure to output the local
cross-references sections.
(Lref_Entity_Status): new array defining whether an entity is a local
* sem_ch3.adb (Analyze_Object_Declaration): call Generate_Reference
with 'I' type when initialization expression is present.
* get_scos.adb, get_scos.ads: Correct comments and typos
From-SVN: r177168
---
gcc/ada/ChangeLog | 61 ++++
gcc/ada/exp_atag.adb | 23 +-
gcc/ada/exp_atag.ads | 8 +-
gcc/ada/exp_ch6.adb | 5 +
gcc/ada/exp_ch7.adb | 37 ++-
gcc/ada/exp_disp.adb | 253 ++++++++++++++---
gcc/ada/get_scos.adb | 4 +-
gcc/ada/get_scos.ads | 8 +-
gcc/ada/lib-writ.adb | 9 +-
gcc/ada/lib-xref.adb | 660 +++++++++++++++++++++++++++++++++++++++----
gcc/ada/lib-xref.ads | 154 +++++++++-
gcc/ada/sem_aux.adb | 10 +-
gcc/ada/sem_ch3.adb | 6 +-
gcc/ada/sem_prag.adb | 4 +-
gcc/ada/sem_res.adb | 12 +-
15 files changed, 1107 insertions(+), 147 deletions(-)
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 93d8439ac16b..0890b264a078 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,64 @@
+2011-08-02 Robert Dewar <dewar@adacore.com>
+
+ * sem_res.adb: Minor reformatting.
+ * sem_prag.adb: Minor reformatting.
+
+2011-08-02 Javier Miranda <miranda@adacore.com>
+
+ * exp_atag.adb, exp_atags.ads
+ (Build_Common_Dispatching_Select_Statement): Replace argument DT_Ptr
+ by the tagged type Entity. Required to use this routine in the VM
+ targets since we do not have available the Tag entity in the VM
+ platforms.
+ * exp_ch6.adb
+ (Expand_N_Subprogram_Body): Do not invoke Build_VM_TSDs if package
+ Ada.Tags has not been previously loaded.
+ * exp_ch7.adb
+ (Expand_N_Package_Declaration, Expand_N_Package_Body): Do not invoke
+ Build_VM_TSDs if package Ada.Tags has not been previously loaded.
+ * sem_aux.adb
+ (Enclosing_Dynamic_Scope): Add missing support to handle the full
+ view of enclosing scopes. Required to handle enclosing scopes that
+ are synchronized types whose full view is a task type.
+ * exp_disp.adb
+ (Build_VM_TSDs): Minor code improvement to avoid generating and
+ analyzing lists with empty nodes.
+ (Make_Disp_Asynchronous_Select_Body): Add support for VM targets.
+ (Make_Disp_Conditional_Select_Body): Add support for VM targets.
+ (Make_Disp_Get_Prim_Op_Kind): Add support for VM targets.
+ (Make_Disp_Timed_Select_Body): Add support for VM targets.
+ (Make_Select_Specific_Data_Table): Add support for VM targets.
+ (Make_VM_TSD): Generate code to initialize the SSD structure of
+ the TSD.
+
+2011-08-02 Yannick Moy <moy@adacore.com>
+
+ * lib-writ.adb (Write_ALI): when ALFA mode is set, write local
+ cross-references section in ALI.
+ * lib-xref.adb, lib-xref.ads (Xref_Entry): add components Sub
+ (enclosing subprogram), Slc (location of Sub) and Sun (unit number of
+ Sub).
+ (Enclosing_Subprogram_Or_Package): new function to return the enclosing
+ subprogram or package entity of a node
+ (Is_Local_Reference_Type): new function returns True for references
+ selected in local cross-references.
+ (Lt): function extracted from Lt in Output_References
+ (Write_Entity_Name): function extracted from Output_References
+ (Generate_Definition): generate reference with type 'D' for definition
+ of objects (object declaration and parameter specification), with
+ appropriate locations and units, for use in local cross-references.
+ (Generate_Reference): update fields Sub, Slc and Sun. Keep newly created
+ references of type 'I' for initialization in object definition.
+ (Output_References): move part of function Lt and procedure
+ Write_Entity_Name outside of the body. Ignore references of types 'D'
+ and 'I' introduced for local cross-references.
+ (Output_Local_References): new procedure to output the local
+ cross-references sections.
+ (Lref_Entity_Status): new array defining whether an entity is a local
+ * sem_ch3.adb (Analyze_Object_Declaration): call Generate_Reference
+ with 'I' type when initialization expression is present.
+ * get_scos.adb, get_scos.ads: Correct comments and typos
+
2011-08-02 Javier Miranda <miranda@adacore.com>
* exp_ch6.adb (Expand_N_Subprogram_Body): Enable generation of TSDs in
diff --git a/gcc/ada/exp_atag.adb b/gcc/ada/exp_atag.adb
index 7ed2a3f5f840..f89263c50c01 100644
--- a/gcc/ada/exp_atag.adb
+++ b/gcc/ada/exp_atag.adb
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2006-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 2006-2011, 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- --
@@ -31,6 +31,7 @@ with Exp_Util; use Exp_Util;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
+with Opt; use Opt;
with Rtsfind; use Rtsfind;
with Sinfo; use Sinfo;
with Sem_Aux; use Sem_Aux;
@@ -71,9 +72,11 @@ package body Exp_Atag is
procedure Build_Common_Dispatching_Select_Statements
(Loc : Source_Ptr;
- DT_Ptr : Entity_Id;
+ Typ : Entity_Id;
Stmts : List_Id)
is
+ Tag_Node : Node_Id;
+
begin
-- Generate:
-- C := get_prim_op_kind (tag! (<type>VP), S);
@@ -81,6 +84,19 @@ package body Exp_Atag is
-- where C is the out parameter capturing the call kind and S is the
-- dispatch table slot number.
+ if Tagged_Type_Expansion then
+ Tag_Node :=
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To
+ (Node (First_Elmt (Access_Disp_Table (Typ))), Loc));
+
+ else
+ Tag_Node :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Typ, Loc),
+ Attribute_Name => Name_Tag);
+ end if;
+
Append_To (Stmts,
Make_Assignment_Statement (Loc,
Name => Make_Identifier (Loc, Name_uC),
@@ -88,8 +104,7 @@ package body Exp_Atag is
Make_Function_Call (Loc,
Name => New_Occurrence_Of (RTE (RE_Get_Prim_Op_Kind), Loc),
Parameter_Associations => New_List (
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Reference_To (DT_Ptr, Loc)),
+ Tag_Node,
Make_Identifier (Loc, Name_uS)))));
-- Generate:
diff --git a/gcc/ada/exp_atag.ads b/gcc/ada/exp_atag.ads
index 384a2d0baa3a..586904bd381c 100644
--- a/gcc/ada/exp_atag.ads
+++ b/gcc/ada/exp_atag.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2006-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 2006-2011, 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- --
@@ -35,9 +35,9 @@ package Exp_Atag is
-- location used in constructing the corresponding nodes.
procedure Build_Common_Dispatching_Select_Statements
- (Loc : Source_Ptr;
- DT_Ptr : Entity_Id;
- Stmts : List_Id);
+ (Loc : Source_Ptr;
+ Typ : Entity_Id;
+ Stmts : List_Id);
-- Ada 2005 (AI-345): Generate statements that are common between timed,
-- asynchronous, and conditional select expansion.
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index b9af60ead86e..8a842fba5b2c 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -5125,8 +5125,13 @@ package body Exp_Ch6 is
-- VM targets, we now generate the Type Specific Data record of all the
-- enclosing tagged type declarations.
+ -- If the runtime package Ada_Tags has not been loaded then this
+ -- subprogram does not have tagged type declarations and there is no
+ -- need to search for tagged types to generate their TSDs.
+
if not Tagged_Type_Expansion
and then Unit (Cunit (Main_Unit)) = N
+ and then RTU_Loaded (Ada_Tags)
then
Build_VM_TSDs (N);
end if;
diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index d2c7725dec14..8063601256b8 100644
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -1560,7 +1560,15 @@ package body Exp_Ch7 is
-- we must generate the corresponding Type Specific Data record.
elsif Unit (Cunit (Main_Unit)) = N then
- Build_VM_TSDs (N);
+
+ -- If the runtime package Ada_Tags has not been loaded then
+ -- this package does not have tagged type declarations and
+ -- there is no need to search for tagged types to generate
+ -- their TSDs.
+
+ if RTU_Loaded (Ada_Tags) then
+ Build_VM_TSDs (N);
+ end if;
end if;
end if;
@@ -1670,22 +1678,29 @@ package body Exp_Ch7 is
elsif Unit (Cunit (Main_Unit)) = N then
- -- Enter the scope of the package because the new declarations are
- -- appended at the end of the package and must be analyzed in that
- -- context.
+ -- If the runtime package Ada_Tags has not been loaded then
+ -- this package does not have tagged types and there is no need
+ -- to search for tagged types to generate their TSDs.
+
+ if RTU_Loaded (Ada_Tags) then
+
+ -- Enter the scope of the package because the new declarations
+ -- are appended at the end of the package and must be analyzed
+ -- in that context.
- Push_Scope (Id);
+ Push_Scope (Id);
- if Is_Generic_Instance (Main_Unit_Entity) then
- if Package_Instantiation (Main_Unit_Entity) = N then
+ if Is_Generic_Instance (Main_Unit_Entity) then
+ if Package_Instantiation (Main_Unit_Entity) = N then
+ Build_VM_TSDs (N);
+ end if;
+
+ else
Build_VM_TSDs (N);
end if;
- else
- Build_VM_TSDs (N);
+ Pop_Scope;
end if;
-
- Pop_Scope;
end if;
end if;
diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index 9eff2347e80a..4f0fc0fbe873 100644
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -474,7 +474,7 @@ package body Exp_Disp is
-------------------
procedure Build_VM_TSDs (N : Entity_Id) is
- Target_List : List_Id;
+ Target_List : List_Id := No_List;
procedure Build_TSDs (List : List_Id);
-- Build the static dispatch table of tagged types found in the list of
@@ -538,6 +538,10 @@ package body Exp_Disp is
null;
else
+ if No (Target_List) then
+ Target_List := New_List;
+ end if;
+
Append_List_To (Target_List,
Make_VM_TSD (Defining_Entity (D)));
end if;
@@ -552,9 +556,9 @@ package body Exp_Disp is
------------------------
procedure Build_Package_TSDs (N : Node_Id) is
- Spec : constant Node_Id := Specification (N);
- Vis_Decls : constant List_Id := Visible_Declarations (Spec);
- Priv_Decls : constant List_Id := Private_Declarations (Spec);
+ Spec : constant Node_Id := Specification (N);
+ Vis_Decls : constant List_Id := Visible_Declarations (Spec);
+ Priv_Decls : constant List_Id := Private_Declarations (Spec);
begin
if Present (Priv_Decls) then
@@ -571,6 +575,7 @@ package body Exp_Disp is
begin
if not Expander_Active
or else No_Run_Time_Mode
+ or else Tagged_Type_Expansion
or else not RTE_Available (RE_Type_Specific_Data)
then
return;
@@ -583,25 +588,33 @@ package body Exp_Disp is
Priv_Decls : constant List_Id := Private_Declarations (Spec);
begin
- Target_List := New_List;
Build_Package_TSDs (N);
- Analyze_List (Target_List);
- if Present (Priv_Decls)
- and then Is_Non_Empty_List (Priv_Decls)
- then
- Append_List (Target_List, Priv_Decls);
- else
- Append_List (Target_List, Vis_Decls);
+ if Present (Target_List) then
+ Analyze_List (Target_List);
+
+ if Present (Priv_Decls)
+ and then Is_Non_Empty_List (Priv_Decls)
+ then
+ Append_List (Target_List, Priv_Decls);
+ else
+ Append_List (Target_List, Vis_Decls);
+ end if;
end if;
end;
elsif Nkind_In (N, N_Package_Body, N_Subprogram_Body) then
if Is_Non_Empty_List (Declarations (N)) then
- Target_List := New_List;
- Build_TSDs (Declarations (N));
- Analyze_List (Target_List);
- Append_List (Target_List, Declarations (N));
+ Build_TSDs (Declarations (N));
+
+ if Nkind (N) = N_Subprogram_Body then
+ Build_TSDs (Statements (Handled_Statement_Sequence (N)));
+ end if;
+
+ if Present (Target_List) then
+ Analyze_List (Target_List);
+ Append_List (Target_List, Declarations (N));
+ end if;
end if;
end if;
end Build_VM_TSDs;
@@ -2209,10 +2222,10 @@ package body Exp_Disp is
Com_Block : Entity_Id;
Conc_Typ : Entity_Id := Empty;
Decls : constant List_Id := New_List;
- DT_Ptr : Entity_Id;
Loc : constant Source_Ptr := Sloc (Typ);
Obj_Ref : Node_Id;
Stmts : constant List_Id := New_List;
+ Tag_Node : Node_Id;
begin
pragma Assert (not Restriction_Active (No_Dispatching_Calls));
@@ -2231,8 +2244,6 @@ package body Exp_Disp is
New_List (Make_Null_Statement (Loc))));
end if;
- DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
-
if Is_Concurrent_Record_Type (Typ) then
Conc_Typ := Corresponding_Concurrent_Type (Typ);
@@ -2243,6 +2254,18 @@ package body Exp_Disp is
-- where I will be used to capture the entry index of the primitive
-- wrapper at position S.
+ if Tagged_Type_Expansion then
+ Tag_Node :=
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To
+ (Node (First_Elmt (Access_Disp_Table (Typ))), Loc));
+ else
+ Tag_Node :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Typ, Loc),
+ Attribute_Name => Name_Tag);
+ end if;
+
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier =>
@@ -2255,8 +2278,7 @@ package body Exp_Disp is
New_Reference_To (RTE (RE_Get_Entry_Index), Loc),
Parameter_Associations =>
New_List (
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Reference_To (DT_Ptr, Loc)),
+ Tag_Node,
Make_Identifier (Loc, Name_uS)))));
if Ekind (Conc_Typ) = E_Protected_Type then
@@ -2553,9 +2575,9 @@ package body Exp_Disp is
Blk_Nam : Entity_Id;
Conc_Typ : Entity_Id := Empty;
Decls : constant List_Id := New_List;
- DT_Ptr : Entity_Id;
Obj_Ref : Node_Id;
Stmts : constant List_Id := New_List;
+ Tag_Node : Node_Id;
begin
pragma Assert (not Restriction_Active (No_Dispatching_Calls));
@@ -2574,8 +2596,6 @@ package body Exp_Disp is
New_List (Make_Null_Statement (Loc))));
end if;
- DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
-
if Is_Concurrent_Record_Type (Typ) then
Conc_Typ := Corresponding_Concurrent_Type (Typ);
@@ -2603,7 +2623,7 @@ package body Exp_Disp is
-- return;
-- end if;
- Build_Common_Dispatching_Select_Statements (Loc, DT_Ptr, Stmts);
+ Build_Common_Dispatching_Select_Statements (Loc, Typ, Stmts);
-- Generate:
-- Bnn : Communication_Block;
@@ -2624,6 +2644,19 @@ package body Exp_Disp is
-- I is the entry index and S is the dispatch table slot
+ if Tagged_Type_Expansion then
+ Tag_Node :=
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To
+ (Node (First_Elmt (Access_Disp_Table (Typ))), Loc));
+
+ else
+ Tag_Node :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Typ, Loc),
+ Attribute_Name => Name_Tag);
+ end if;
+
Append_To (Stmts,
Make_Assignment_Statement (Loc,
Name => Make_Identifier (Loc, Name_uI),
@@ -2633,8 +2666,7 @@ package body Exp_Disp is
New_Reference_To (RTE (RE_Get_Entry_Index), Loc),
Parameter_Associations =>
New_List (
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Reference_To (DT_Ptr, Loc)),
+ Tag_Node,
Make_Identifier (Loc, Name_uS)))));
if Ekind (Conc_Typ) = E_Protected_Type then
@@ -2848,8 +2880,8 @@ package body Exp_Disp is
function Make_Disp_Get_Prim_Op_Kind_Body
(Typ : Entity_Id) return Node_Id
is
- Loc : constant Source_Ptr := Sloc (Typ);
- DT_Ptr : Entity_Id;
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Tag_Node : Node_Id;
begin
pragma Assert (not Restriction_Active (No_Dispatching_Calls));
@@ -2866,14 +2898,25 @@ package body Exp_Disp is
New_List (Make_Null_Statement (Loc))));
end if;
- DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
-
-- Generate:
-- C := get_prim_op_kind (tag! (<type>VP), S);
-- where C is the out parameter capturing the call kind and S is the
-- dispatch table slot number.
+ if Tagged_Type_Expansion then
+ Tag_Node :=
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To
+ (Node (First_Elmt (Access_Disp_Table (Typ))), Loc));
+
+ else
+ Tag_Node :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Typ, Loc),
+ Attribute_Name => Name_Tag);
+ end if;
+
return
Make_Subprogram_Body (Loc,
Specification =>
@@ -2891,9 +2934,8 @@ package body Exp_Disp is
Name =>
New_Reference_To (RTE (RE_Get_Prim_Op_Kind), Loc),
Parameter_Associations => New_List (
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Reference_To (DT_Ptr, Loc)),
- Make_Identifier (Loc, Name_uS)))))));
+ Tag_Node,
+ Make_Identifier (Loc, Name_uS)))))));
end Make_Disp_Get_Prim_Op_Kind_Body;
-------------------------------------
@@ -3380,9 +3422,9 @@ package body Exp_Disp is
Loc : constant Source_Ptr := Sloc (Typ);
Conc_Typ : Entity_Id := Empty;
Decls : constant List_Id := New_List;
- DT_Ptr : Entity_Id;
Obj_Ref : Node_Id;
Stmts : constant List_Id := New_List;
+ Tag_Node : Node_Id;
begin
pragma Assert (not Restriction_Active (No_Dispatching_Calls));
@@ -3401,8 +3443,6 @@ package body Exp_Disp is
New_List (Make_Null_Statement (Loc))));
end if;
- DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
-
if Is_Concurrent_Record_Type (Typ) then
Conc_Typ := Corresponding_Concurrent_Type (Typ);
@@ -3430,13 +3470,26 @@ package body Exp_Disp is
-- return;
-- end if;
- Build_Common_Dispatching_Select_Statements (Loc, DT_Ptr, Stmts);
+ Build_Common_Dispatching_Select_Statements (Loc, Typ, Stmts);
-- Generate:
-- I := Get_Entry_Index (tag! (<type>VP), S);
-- I is the entry index and S is the dispatch table slot
+ if Tagged_Type_Expansion then
+ Tag_Node :=
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To
+ (Node (First_Elmt (Access_Disp_Table (Typ))), Loc));
+
+ else
+ Tag_Node :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Typ, Loc),
+ Attribute_Name => Name_Tag);
+ end if;
+
Append_To (Stmts,
Make_Assignment_Statement (Loc,
Name => Make_Identifier (Loc, Name_uI),
@@ -3446,8 +3499,7 @@ package body Exp_Disp is
New_Reference_To (RTE (RE_Get_Entry_Index), Loc),
Parameter_Associations =>
New_List (
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Reference_To (DT_Ptr, Loc)),
+ Tag_Node,
Make_Identifier (Loc, Name_uS)))));
-- Protected case
@@ -6258,16 +6310,21 @@ package body Exp_Disp is
Loc : constant Source_Ptr := Sloc (Typ);
Result : constant List_Id := New_List;
AI : Elmt_Id;
- I_Depth : Nat := 0; -- why initialized here ???
+ I_Depth : Nat;
Iface_Table_Node : Node_Id;
- Num_Ifaces : Nat := 0; -- why initialized here ???
+ Nb_Prim : Nat;
+ Num_Ifaces : Nat;
TSD_Aggr_List : List_Id;
Typ_Ifaces : Elist_Id;
TSD_Tags_List : List_Id;
Tname : constant Name_Id := Chars (Typ);
+ Name_SSD : constant Name_Id :=
+ New_External_Name (Tname, 'S', Suffix_Index => -1);
Name_TSD : constant Name_Id :=
New_External_Name (Tname, 'B', Suffix_Index => -1);
+ SSD : constant Entity_Id :=
+ Make_Defining_Identifier (Loc, Name_SSD);
TSD : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_TSD);
begin
@@ -6359,6 +6416,7 @@ package body Exp_Disp is
Collect_Interfaces (Typ, Typ_Ifaces);
+ Num_Ifaces := 0;
AI := First_Elmt (Typ_Ifaces);
while Present (AI) loop
Num_Ifaces := Num_Ifaces + 1;
@@ -6420,6 +6478,68 @@ package body Exp_Disp is
Append_To (TSD_Aggr_List, Iface_Table_Node);
end if;
+ -- Generate the Select Specific Data table for synchronized types that
+ -- implement synchronized interfaces. The size of the table is
+ -- constrained by the number of non-predefined primitive operations.
+
+ -- Count the non-predefined primitive operations
+
+ Nb_Prim := 0;
+
+ declare
+ Prim_Elmt : Elmt_Id;
+ Prim : Entity_Id;
+ begin
+ Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
+ while Present (Prim_Elmt) loop
+ Prim := Node (Prim_Elmt);
+
+ if not (Is_Predefined_Dispatching_Operation (Prim)
+ or else Is_Predefined_Dispatching_Alias (Prim))
+ then
+ Nb_Prim := Nb_Prim + 1;
+ end if;
+
+ Next_Elmt (Prim_Elmt);
+ end loop;
+ end;
+
+ if RTE_Record_Component_Available (RE_SSD) then
+ if Ada_Version >= Ada_2005
+ and then Has_DT (Typ)
+ and then Is_Concurrent_Record_Type (Typ)
+ and then Has_Interfaces (Typ)
+ and then Nb_Prim > 0
+ and then not Is_Abstract_Type (Typ)
+ and then not Is_Controlled (Typ)
+ and then not Restriction_Active (No_Dispatching_Calls)
+ and then not Restriction_Active (No_Select_Statements)
+ then
+ Append_To (Result,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => SSD,
+ Aliased_Present => True,
+ Object_Definition =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark => New_Reference_To (
+ RTE (RE_Select_Specific_Data), Loc),
+ Constraint =>
+ Make_Index_Or_Discriminant_Constraint (Loc,
+ Constraints => New_List (
+ Make_Integer_Literal (Loc, Nb_Prim))))));
+
+ -- This table is initialized by Make_Select_Specific_Data_Table,
+ -- which calls Set_Entry_Index and Set_Prim_Op_Kind.
+
+ Append_To (TSD_Aggr_List,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (SSD, Loc),
+ Attribute_Name => Name_Unchecked_Access));
+ else
+ Append_To (TSD_Aggr_List, Make_Null (Loc));
+ end if;
+ end if;
+
-- Initialize the table of ancestor tags. In case of interface types
-- this table is not needed.
@@ -6510,6 +6630,21 @@ package body Exp_Disp is
Prefix => New_Reference_To (TSD, Loc),
Attribute_Name => Name_Unrestricted_Access))));
+ -- Populate the two auxiliary tables used for dispatching asynchronous,
+ -- conditional and timed selects for synchronized types that implement
+ -- a limited interface. Skip this step in Ravenscar profile or when
+ -- general dispatching is forbidden.
+
+ if Ada_Version >= Ada_2005
+ and then Is_Concurrent_Record_Type (Typ)
+ and then Has_Interfaces (Typ)
+ and then not Restriction_Active (No_Dispatching_Calls)
+ and then not Restriction_Active (No_Select_Statements)
+ then
+ Append_List_To (Result,
+ Make_Select_Specific_Data_Table (Typ));
+ end if;
+
return Result;
end Make_VM_TSD;
@@ -6525,7 +6660,6 @@ package body Exp_Disp is
Conc_Typ : Entity_Id;
Decls : List_Id;
- DT_Ptr : Entity_Id;
Prim : Entity_Id;
Prim_Als : Entity_Id;
Prim_Elmt : Elmt_Id;
@@ -6567,13 +6701,15 @@ package body Exp_Disp is
return Uint_0;
end Find_Entry_Index;
+ -- Local variables
+
+ Tag_Node : Node_Id;
+
-- Start of processing for Make_Select_Specific_Data_Table
begin
pragma Assert (not Restriction_Active (No_Dispatching_Calls));
- DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
-
if Present (Corresponding_Concurrent_Type (Typ)) then
Conc_Typ := Corresponding_Concurrent_Type (Typ);
@@ -6631,11 +6767,23 @@ package body Exp_Disp is
-- type. Generate:
-- Ada.Tags.Set_Prim_Op_Kind (DT_Ptr, <position>, <kind>);
+ if Tagged_Type_Expansion then
+ Tag_Node :=
+ New_Reference_To
+ (Node (First_Elmt (Access_Disp_Table (Typ))), Loc);
+
+ else
+ Tag_Node :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Typ, Loc),
+ Attribute_Name => Name_Tag);
+ end if;
+
Append_To (Assignments,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Set_Prim_Op_Kind), Loc),
Parameter_Associations => New_List (
- New_Reference_To (DT_Ptr, Loc),
+ Tag_Node,
Make_Integer_Literal (Loc, Prim_Pos),
Prim_Op_Kind (Alias (Prim), Typ))));
@@ -6653,12 +6801,23 @@ package body Exp_Disp is
-- Ada.Tags.Set_Entry_Index
-- (DT_Ptr, <position>, <index>);
+ if Tagged_Type_Expansion then
+ Tag_Node :=
+ New_Reference_To
+ (Node (First_Elmt (Access_Disp_Table (Typ))), Loc);
+ else
+ Tag_Node :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Typ, Loc),
+ Attribute_Name => Name_Tag);
+ end if;
+
Append_To (Assignments,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Reference_To (RTE (RE_Set_Entry_Index), Loc),
Parameter_Associations => New_List (
- New_Reference_To (DT_Ptr, Loc),
+ Tag_Node,
Make_Integer_Literal (Loc, Prim_Pos),
Make_Integer_Literal (Loc,
Find_Entry_Index (Wrapped_Entity (Prim_Als))))));
diff --git a/gcc/ada/get_scos.adb b/gcc/ada/get_scos.adb
index 70d77c80b6ad..074c65878540 100644
--- a/gcc/ada/get_scos.adb
+++ b/gcc/ada/get_scos.adb
@@ -2,11 +2,11 @@
-- --
-- GNAT COMPILER COMPONENTS --
-- --
--- G E T _ S C O S --
+-- G E T _ S C O S --
-- --
-- B o d y --
-- --
--- Copyright (C) 2009, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2011, 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- --
diff --git a/gcc/ada/get_scos.ads b/gcc/ada/get_scos.ads
index 639d938bbfe9..f440b2238cfc 100644
--- a/gcc/ada/get_scos.ads
+++ b/gcc/ada/get_scos.ads
@@ -2,11 +2,11 @@
-- --
-- GNAT COMPILER COMPONENTS --
-- --
--- G E T _ S C O S --
+-- G E T _ S C O S --
-- --
-- S p e c --
-- --
--- Copyright (C) 2009, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2011, 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- --
@@ -32,7 +32,7 @@ generic
with function Getc return Character is <>;
-- Get next character, positioning the ALI file ready to read the following
- -- character (equivalent to calling Skipc, then Nextc). If the end of file
+ -- character (equivalent to calling Nextc, then Skipc). If the end of file
-- is encountered, the value Types.EOF is returned.
with function Nextc return Character is <>;
@@ -54,5 +54,5 @@ procedure Get_SCOs;
-- first character of the line following the SCO information (which will
-- never start with a 'C').
--
--- If a format error is detected in the input, then an exceptions is raised
+-- If a format error is detected in the input, then an exception is raised
-- (Ada.IO_Exceptions.Data_Error), with the file positioned to the error.
diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb
index d1e442a32b07..ecabb393f7f1 100644
--- a/gcc/ada/lib-writ.adb
+++ b/gcc/ada/lib-writ.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, 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- --
@@ -1301,6 +1301,13 @@ package body Lib.Writ is
SCO_Output;
end if;
+ -- Output references by subprogram
+
+ if ALFA_Mode then
+ Write_Info_EOL;
+ Output_Local_References;
+ end if;
+
-- Output final blank line and we are done. This final blank line is
-- probably junk, but we don't feel like making an incompatible change!
diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb
index 4c4cef0f3a9a..d44f1b8eccf0 100644
--- a/gcc/ada/lib-xref.adb
+++ b/gcc/ada/lib-xref.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2011, 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- --
@@ -62,6 +62,9 @@ package body Lib.Xref is
Ent : Entity_Id;
-- Entity referenced (E parameter to Generate_Reference)
+ Sub : Entity_Id;
+ -- Entity of the closest enclosing subprogram or package
+
Def : Source_Ptr;
-- Original source location for entity being referenced. Note that these
-- values are used only during the output process, they are not set when
@@ -73,12 +76,18 @@ package body Lib.Xref is
-- to Generate_Reference). Set to No_Location for the case of a
-- defining occurrence.
+ Slc : Source_Ptr;
+ -- Original source location for entity Sub
+
Typ : Character;
-- Reference type (Typ param to Generate_Reference)
Eun : Unit_Number_Type;
-- Unit number corresponding to Ent
+ Sun : Unit_Number_Type;
+ -- Unit number corresponding to Sub
+
Lun : Unit_Number_Type;
-- Unit number corresponding to Loc. Value is undefined and not
-- referenced if Loc is set to No_Location.
@@ -97,12 +106,71 @@ package body Lib.Xref is
-- Local Subprograms --
------------------------
+ function Enclosing_Subprogram_Or_Package (N : Node_Id) return Entity_Id;
+ -- Return the closest enclosing subprogram of package
+
+ function Is_Local_Reference_Type (Typ : Character) return Boolean;
+ -- Return whether Typ is a suitable reference type for a local reference
+
procedure Generate_Prim_Op_References (Typ : Entity_Id);
-- For a tagged type, generate implicit references to its primitive
-- operations, for source navigation. This is done right before emitting
-- cross-reference information rather than at the freeze point of the type
-- in order to handle late bodies that are primitive operations.
+ function Lt (T1, T2 : Xref_Entry) return Boolean;
+ -- Order cross-references
+
+ procedure Write_Entity_Name (E : Entity_Id; Cursrc : Source_Buffer_Ptr);
+ -- Output entity name for E. We use the occurrence from the actual
+ -- source program at the definition point.
+
+ -------------------------------------
+ -- Enclosing_Subprogram_Or_Package --
+ -------------------------------------
+
+ function Enclosing_Subprogram_Or_Package (N : Node_Id) return Entity_Id
+ is
+ Result : Entity_Id;
+
+ begin
+ Result := N;
+ loop
+ exit when No (Result);
+
+ case Nkind (Result) is
+ when N_Package_Specification =>
+ Result := Defining_Unit_Name (Result);
+ exit;
+
+ when N_Package_Body =>
+ Result := Corresponding_Spec (Result);
+ exit;
+
+ when N_Subprogram_Specification =>
+ Result := Defining_Unit_Name (Result);
+ exit;
+
+ when N_Subprogram_Declaration =>
+ Result := Defining_Unit_Name (Specification (Result));
+ exit;
+
+ when N_Subprogram_Body =>
+ Result := Defining_Unit_Name (Specification (Result));
+ exit;
+
+ when others =>
+ Result := Parent (Result);
+ end case;
+ end loop;
+
+ if Nkind (Result) = N_Defining_Program_Unit_Name then
+ Result := Defining_Identifier (Result);
+ end if;
+
+ return Result;
+ end Enclosing_Subprogram_Or_Package;
+
-------------------------
-- Generate_Definition --
-------------------------
@@ -146,11 +214,39 @@ package body Lib.Xref is
Loc := Original_Location (Sloc (E));
Xrefs.Table (Indx).Ent := E;
- Xrefs.Table (Indx).Def := No_Location;
- Xrefs.Table (Indx).Loc := No_Location;
- Xrefs.Table (Indx).Typ := ' ';
+
+ if ALFA_Mode
+ and then Nkind_In (Parent (E),
+ N_Object_Declaration,
+ N_Parameter_Specification)
+ then
+ -- In ALFA mode, define precise 'D' references for object
+ -- definition.
+
+ declare
+ Sub : constant Entity_Id := Enclosing_Subprogram_Or_Package (E);
+ Slc : constant Source_Ptr := Original_Location (Sloc (Sub));
+ Sun : constant Unit_Number_Type := Get_Source_Unit (Slc);
+ begin
+ Xrefs.Table (Indx).Typ := 'D';
+ Xrefs.Table (Indx).Sub := Sub;
+ Xrefs.Table (Indx).Def := Loc;
+ Xrefs.Table (Indx).Loc := Loc;
+ Xrefs.Table (Indx).Slc := Slc;
+ Xrefs.Table (Indx).Lun := Get_Source_Unit (Loc);
+ Xrefs.Table (Indx).Sun := Sun;
+ end;
+ else
+ Xrefs.Table (Indx).Typ := ' ';
+ Xrefs.Table (Indx).Sub := Empty;
+ Xrefs.Table (Indx).Def := No_Location;
+ Xrefs.Table (Indx).Loc := No_Location;
+ Xrefs.Table (Indx).Slc := No_Location;
+ Xrefs.Table (Indx).Lun := No_Unit;
+ Xrefs.Table (Indx).Sun := No_Unit;
+ end if;
+
Xrefs.Table (Indx).Eun := Get_Source_Unit (Loc);
- Xrefs.Table (Indx).Lun := No_Unit;
Set_Has_Xref_Entry (E);
if In_Inlined_Body then
@@ -275,7 +371,9 @@ package body Lib.Xref is
Nod : Node_Id;
Ref : Source_Ptr;
Def : Source_Ptr;
+ Slc : Source_Ptr;
Ent : Entity_Id;
+ Sub : Entity_Id;
Call : Node_Id;
Formal : Entity_Id;
@@ -495,6 +593,7 @@ package body Lib.Xref is
if not In_Extended_Main_Source_Unit (N) then
if Typ = 'e'
+ or else Typ = 'I'
or else Typ = 'p'
or else Typ = 'i'
or else Typ = 'k'
@@ -835,13 +934,17 @@ package body Lib.Xref is
-- Record reference to entity
+ Sub := Enclosing_Subprogram_Or_Package (N);
+
Ref := Original_Location (Sloc (Nod));
Def := Original_Location (Sloc (Ent));
+ Slc := Original_Location (Sloc (Sub));
Xrefs.Increment_Last;
Indx := Xrefs.Last;
Xrefs.Table (Indx).Loc := Ref;
+ Xrefs.Table (Indx).Slc := Slc;
-- Overriding operations are marked with 'P'
@@ -856,7 +959,9 @@ package body Lib.Xref is
Xrefs.Table (Indx).Eun := Get_Source_Unit (Def);
Xrefs.Table (Indx).Lun := Get_Source_Unit (Ref);
+ Xrefs.Table (Indx).Sun := Get_Source_Unit (Slc);
Xrefs.Table (Indx).Ent := Ent;
+ Xrefs.Table (Indx).Sub := Sub;
Set_Has_Xref_Entry (Ent);
end if;
end Generate_Reference;
@@ -931,6 +1036,62 @@ package body Lib.Xref is
Xrefs.Init;
end Initialize;
+ -----------------------------
+ -- Is_Local_Reference_Type --
+ -----------------------------
+
+ function Is_Local_Reference_Type (Typ : Character) return Boolean is
+ begin
+ return Typ = 'r' or else Typ = 'm' or else Typ = 's'
+ or else Typ = 'I' or else Typ = 'D';
+ end Is_Local_Reference_Type;
+
+ --------
+ -- Lt --
+ --------
+
+ function Lt (T1, T2 : Xref_Entry) return Boolean is
+ begin
+ -- First test: if entity is in different unit, sort by unit
+
+ if T1.Eun /= T2.Eun then
+ return Dependency_Num (T1.Eun) < Dependency_Num (T2.Eun);
+
+ -- Second test: within same unit, sort by entity Sloc
+
+ elsif T1.Def /= T2.Def then
+ return T1.Def < T2.Def;
+
+ -- Third test: sort definitions ahead of references
+
+ elsif T1.Loc = No_Location then
+ return True;
+
+ elsif T2.Loc = No_Location then
+ return False;
+
+ -- Fourth test: for same entity, sort by reference location unit
+
+ elsif T1.Lun /= T2.Lun then
+ return Dependency_Num (T1.Lun) < Dependency_Num (T2.Lun);
+
+ -- Fifth test: order of location within referencing unit
+
+ elsif T1.Loc /= T2.Loc then
+ return T1.Loc < T2.Loc;
+
+ -- Finally, for two locations at the same address, we prefer
+ -- the one that does NOT have the type 'r' so that a modification
+ -- or extension takes preference, when there are more than one
+ -- reference at the same location. As a result, in the case of
+ -- entities that are in-out actuals, the read reference follows
+ -- the modify reference.
+
+ else
+ return T2.Typ = 'r';
+ end if;
+ end Lt;
+
-----------------------
-- Output_References --
-----------------------
@@ -1409,44 +1570,7 @@ package body Lib.Xref is
T2 : Xref_Entry renames Xrefs.Table (Rnums (Nat (Op2)));
begin
- -- First test: if entity is in different unit, sort by unit
-
- if T1.Eun /= T2.Eun then
- return Dependency_Num (T1.Eun) < Dependency_Num (T2.Eun);
-
- -- Second test: within same unit, sort by entity Sloc
-
- elsif T1.Def /= T2.Def then
- return T1.Def < T2.Def;
-
- -- Third test: sort definitions ahead of references
-
- elsif T1.Loc = No_Location then
- return True;
-
- elsif T2.Loc = No_Location then
- return False;
-
- -- Fourth test: for same entity, sort by reference location unit
-
- elsif T1.Lun /= T2.Lun then
- return Dependency_Num (T1.Lun) < Dependency_Num (T2.Lun);
-
- -- Fifth test: order of location within referencing unit
-
- elsif T1.Loc /= T2.Loc then
- return T1.Loc < T2.Loc;
-
- -- Finally, for two locations at the same address, we prefer
- -- the one that does NOT have the type 'r' so that a modification
- -- or extension takes preference, when there are more than one
- -- reference at the same location. As a result, in the case of
- -- entities that are in-out actuals, the read reference follows
- -- the modify reference.
-
- else
- return T2.Typ = 'r';
- end if;
+ return Lt (T1, T2);
end Lt;
----------
@@ -1852,17 +1976,28 @@ package body Lib.Xref is
end if;
end if;
- -- Only output reference if interesting type of entity, and
- -- suppress self references, except for bodies that act as
- -- specs. Also suppress definitions of body formals (we only
- -- treat these as references, and the references were
- -- separately recorded).
+ -- Only output reference if interesting type of entity
if Ctyp = ' '
+
+ -- Suppress references to object definitions, used for local
+ -- references.
+
+ or else XE.Typ = 'D'
+ or else XE.Typ = 'I'
+
+ -- Suppress self references, except for bodies that act as
+ -- specs.
+
or else (XE.Loc = XE.Def
and then
(XE.Typ /= 'b'
or else not Is_Subprogram (XE.Ent)))
+
+ -- Also suppress definitions of body formals (we only
+ -- treat these as references, and the references were
+ -- separately recorded).
+
or else (Is_Formal (XE.Ent)
and then Present (Spec_Entity (XE.Ent)))
then
@@ -2253,4 +2388,433 @@ package body Lib.Xref is
end Output_Refs;
end Output_References;
+ -----------------------------
+ -- Output_Local_References --
+ -----------------------------
+
+ procedure Output_Local_References is
+
+ Nrefs : Nat := Xrefs.Last;
+ -- Number of references in table. This value may get reset (reduced)
+ -- when we eliminate duplicate reference entries as well as references
+ -- not suitable for local cross-references.
+
+ Rnums : array (0 .. Nrefs) of Nat;
+ -- This array contains numbers of references in the Xrefs table.
+ -- This list is sorted in output order. The extra 0'th entry is
+ -- convenient for the call to sort. When we sort the table, we
+ -- move the entries in Rnums around, but we do not move the
+ -- original table entries.
+
+ Curxu : Unit_Number_Type;
+ -- Current xref unit
+
+ Curru : Unit_Number_Type;
+ -- Current reference unit for one entity
+
+ Cursu : Unit_Number_Type;
+ -- Current reference unit for one enclosing subprogram
+
+ Cursrc : Source_Buffer_Ptr;
+ -- Current xref unit source text
+
+ Cursub : Entity_Id;
+ -- Current enclosing subprogram
+
+ Curent : Entity_Id;
+ -- Current entity
+
+ Curnam : String (1 .. Name_Buffer'Length);
+ Curlen : Natural;
+ -- Simple name and length of current entity
+
+ Curdef : Source_Ptr;
+ -- Original source location for current entity
+
+ Crloc : Source_Ptr;
+ -- Current reference location
+
+ Ctyp : Character;
+ -- Entity type character
+
+ Prevt : Character;
+ -- Reference kind of previous reference
+
+ function Lt (Op1, Op2 : Natural) return Boolean;
+ -- Comparison function for Sort call
+
+ function Name_Change (X : Entity_Id) return Boolean;
+ -- Determines if entity X has a different simple name from Curent
+
+ procedure Move (From : Natural; To : Natural);
+ -- Move procedure for Sort call
+
+ package Sorting is new GNAT.Heap_Sort_G (Move, Lt);
+
+ --------
+ -- Lt --
+ --------
+
+ function Lt (Op1, Op2 : Natural) return Boolean is
+ T1 : Xref_Entry renames Xrefs.Table (Rnums (Nat (Op1)));
+ T2 : Xref_Entry renames Xrefs.Table (Rnums (Nat (Op2)));
+
+ begin
+ if T1.Slc = No_Location then
+ return True;
+
+ elsif T2.Slc = No_Location then
+ return False;
+
+ elsif T1.Sun /= T2.Sun then
+ return Dependency_Num (T1.Sun) < Dependency_Num (T2.Sun);
+
+ elsif T1.Slc /= T2.Slc then
+ return T1.Slc < T2.Slc;
+
+ else
+ return Lt (T1, T2);
+ end if;
+ end Lt;
+
+ ----------
+ -- Move --
+ ----------
+
+ procedure Move (From : Natural; To : Natural) is
+ begin
+ Rnums (Nat (To)) := Rnums (Nat (From));
+ end Move;
+
+ -----------------
+ -- Name_Change --
+ -----------------
+
+ -- Why a string comparison here??? Why not compare Name_Id values???
+
+ function Name_Change (X : Entity_Id) return Boolean is
+ begin
+ Get_Unqualified_Name_String (Chars (X));
+
+ if Name_Len /= Curlen then
+ return True;
+ else
+ return Name_Buffer (1 .. Curlen) /= Curnam (1 .. Curlen);
+ end if;
+ end Name_Change;
+
+ -- Start of processing for Output_Subprogram_References
+ begin
+
+ -- Replace enclosing subprogram pointer by corresponding specification
+ -- when appropriate. This could not be done before as the information
+ -- was not always available when registering references.
+
+ for J in 1 .. Xrefs.Last loop
+ if Present (Xrefs.Table (J).Sub) then
+ declare
+ N : constant Node_Id :=
+ Parent (Parent (Xrefs.Table (J).Sub));
+ Sub : Entity_Id;
+ Slc : Source_Ptr;
+ Sun : Unit_Number_Type;
+ begin
+ if Nkind (N) = N_Subprogram_Body
+ and then not Acts_As_Spec (N)
+ then
+ Sub := Corresponding_Spec (N);
+
+ if Nkind (Sub) = N_Defining_Program_Unit_Name then
+ Sub := Defining_Identifier (Sub);
+ end if;
+
+ Slc := Original_Location (Sloc (Sub));
+ Sun := Get_Source_Unit (Slc);
+
+ Xrefs.Table (J).Sub := Sub;
+ Xrefs.Table (J).Slc := Slc;
+ Xrefs.Table (J).Sun := Sun;
+ end if;
+ end;
+ end if;
+ end loop;
+
+ -- Set up the pointer vector for the sort
+
+ for J in 1 .. Nrefs loop
+ Rnums (J) := J;
+ end loop;
+
+ -- Sort the references
+
+ Sorting.Sort (Integer (Nrefs));
+
+ declare
+ NR : Nat;
+
+ begin
+ -- Eliminate duplicate entries
+
+ -- We need this test for NR because if we force ALI file
+ -- generation in case of errors detected, it may be the case
+ -- that Nrefs is 0, so we should not reset it here
+
+ if Nrefs >= 2 then
+ NR := Nrefs;
+ Nrefs := 1;
+
+ for J in 2 .. NR loop
+ if Xrefs.Table (Rnums (J)) /= Xrefs.Table (Rnums (Nrefs)) then
+ Nrefs := Nrefs + 1;
+ Rnums (Nrefs) := Rnums (J);
+ end if;
+ end loop;
+ end if;
+
+ -- Eliminate entries not appropriate for local references
+
+ NR := Nrefs;
+ Nrefs := 0;
+
+ for J in 1 .. NR loop
+ if Lref_Entity_Status (Ekind (Xrefs.Table (Rnums (J)).Ent))
+ and then Is_Local_Reference_Type (Xrefs.Table (Rnums (J)).Typ)
+ then
+ Nrefs := Nrefs + 1;
+ Rnums (Nrefs) := Rnums (J);
+ end if;
+ end loop;
+ end;
+
+ -- Initialize loop through references
+
+ Curxu := No_Unit;
+ Cursub := Empty;
+ Curent := Empty;
+ Curdef := No_Location;
+ Curru := No_Unit;
+ Cursu := No_Unit;
+ Crloc := No_Location;
+ Prevt := 'm';
+
+ -- Loop to output references
+
+ for Refno in 1 .. Nrefs loop
+ Output_One_Ref : declare
+ Ent : Entity_Id;
+ XE : Xref_Entry renames Xrefs.Table (Rnums (Refno));
+ -- The current entry to be accessed
+
+ begin
+ Ent := XE.Ent;
+ Ctyp := Xref_Entity_Letters (Ekind (Ent));
+
+ -- Start new Unit section if subprogram in new unit
+
+ if XE.Sun /= Cursu then
+ if Write_Info_Col > 1 then
+ Write_Info_EOL;
+ end if;
+
+ Cursu := XE.Sun;
+
+ Write_Info_Initiate ('F');
+ Write_Info_Char (' ');
+ Write_Info_Nat (Dependency_Num (XE.Sun));
+ Write_Info_Char (' ');
+ Write_Info_Name (Reference_Name (Source_Index (XE.Sun)));
+ Write_Info_EOL;
+ end if;
+
+ -- Start new Subprogram section if new subprogram
+
+ if XE.Sub /= Cursub then
+ if Write_Info_Col > 1 then
+ Write_Info_EOL;
+ end if;
+
+ Cursub := XE.Sub;
+ Cursrc := Source_Text (Source_Index (Cursu));
+
+ Write_Info_Initiate ('S');
+ Write_Info_Char (' ');
+ Write_Info_Nat (Int (Get_Logical_Line_Number (XE.Slc)));
+ Write_Info_Char (Xref_Entity_Letters (Ekind (XE.Sub)));
+ Write_Info_Nat (Int (Get_Column_Number (XE.Slc)));
+ Write_Info_Char (' ');
+ Write_Entity_Name (XE.Sub, Cursrc);
+
+ -- Indicate that the entity is in the unit of the current
+ -- local xref section.
+
+ Curru := Cursu;
+
+ -- End of processing for subprogram output
+
+ Curxu := No_Unit;
+ Curent := Empty;
+ end if;
+
+ -- Start new Xref section if new xref unit
+
+ if XE.Eun /= Curxu then
+ if Write_Info_Col > 1 then
+ Write_Info_EOL;
+ end if;
+
+ Curxu := XE.Eun;
+ Cursrc := Source_Text (Source_Index (Curxu));
+
+ Write_Info_Initiate ('X');
+ Write_Info_Char (' ');
+ Write_Info_Nat (Dependency_Num (XE.Eun));
+ Write_Info_Char (' ');
+ Write_Info_Name (Reference_Name (Source_Index (XE.Eun)));
+
+ -- End of processing for Xref section output
+
+ Curru := Cursu;
+ end if;
+
+ -- Start new Entity line if new entity. Note that we
+ -- consider two entities the same if they have the same
+ -- name and source location. This causes entities in
+ -- instantiations to be treated as though they referred
+ -- to the template.
+
+ if No (Curent)
+ or else
+ (XE.Ent /= Curent
+ and then
+ (Name_Change (XE.Ent) or else XE.Def /= Curdef))
+ then
+ Curent := XE.Ent;
+ Curdef := XE.Def;
+
+ Get_Unqualified_Name_String (Chars (XE.Ent));
+ Curlen := Name_Len;
+ Curnam (1 .. Curlen) := Name_Buffer (1 .. Curlen);
+
+ if Write_Info_Col > 1 then
+ Write_Info_EOL;
+ end if;
+
+ -- Write line and column number information
+
+ Write_Info_Nat (Int (Get_Logical_Line_Number (XE.Def)));
+ Write_Info_Char (Ctyp);
+ Write_Info_Nat (Int (Get_Column_Number (XE.Def)));
+ Write_Info_Char (' ');
+
+ -- Output entity name
+
+ Write_Entity_Name (XE.Ent, Cursrc);
+
+ -- End of processing for entity output
+
+ Crloc := No_Location;
+ end if;
+
+ -- Output the reference if it is not as the same location
+ -- as the previous one, or it is a read-reference that
+ -- indicates that the entity is an in-out actual in a call.
+
+ if XE.Loc /= No_Location
+ and then
+ (XE.Loc /= Crloc
+ or else (Prevt = 'm' and then XE.Typ = 'r'))
+ then
+ Crloc := XE.Loc;
+ Prevt := XE.Typ;
+
+ -- Start continuation if line full, else blank
+
+ if Write_Info_Col > 72 then
+ Write_Info_EOL;
+ Write_Info_Initiate ('.');
+ end if;
+
+ Write_Info_Char (' ');
+
+ -- Output file number if changed
+
+ if XE.Lun /= Curru then
+ Curru := XE.Lun;
+ Write_Info_Nat (Dependency_Num (Curru));
+ Write_Info_Char ('|');
+ end if;
+
+ -- Write line and column number information
+
+ Write_Info_Nat (Int (Get_Logical_Line_Number (XE.Loc)));
+ Write_Info_Char (XE.Typ);
+ Write_Info_Nat (Int (Get_Column_Number (XE.Loc)));
+ end if;
+ end Output_One_Ref;
+ end loop;
+
+ Write_Info_EOL;
+ end Output_Local_References;
+
+ -----------------------
+ -- Write_Entity_Name --
+ -----------------------
+
+ procedure Write_Entity_Name (E : Entity_Id; Cursrc : Source_Buffer_Ptr) is
+ P, P2 : Source_Ptr;
+ -- Used to index into source buffer to get entity name
+
+ WC : Char_Code;
+ Err : Boolean;
+ pragma Warnings (Off, WC);
+ pragma Warnings (Off, Err);
+
+ begin
+ P := Original_Location (Sloc (E));
+
+ -- Entity is character literal
+
+ if Cursrc (P) = ''' then
+ Write_Info_Char (Cursrc (P));
+ Write_Info_Char (Cursrc (P + 1));
+ Write_Info_Char (Cursrc (P + 2));
+
+ -- Entity is operator symbol
+
+ elsif Cursrc (P) = '"' or else Cursrc (P) = '%' then
+ Write_Info_Char (Cursrc (P));
+
+ P2 := P;
+ loop
+ P2 := P2 + 1;
+ Write_Info_Char (Cursrc (P2));
+ exit when Cursrc (P2) = Cursrc (P);
+ end loop;
+
+ -- Entity is identifier
+
+ else
+ loop
+ if Is_Start_Of_Wide_Char (Cursrc, P) then
+ Scan_Wide (Cursrc, P, WC, Err);
+ elsif not Identifier_Char (Cursrc (P)) then
+ exit;
+ else
+ P := P + 1;
+ end if;
+ end loop;
+
+ -- Write out the identifier by copying the exact
+ -- source characters used in its declaration. Note
+ -- that this means wide characters will be in their
+ -- original encoded form.
+
+ for J in
+ Original_Location (Sloc (E)) .. P - 1
+ loop
+ Write_Info_Char (Cursrc (J));
+ end loop;
+ end if;
+ end Write_Entity_Name;
+
end Lib.Xref;
diff --git a/gcc/ada/lib-xref.ads b/gcc/ada/lib-xref.ads
index 9fb8b2df5653..1d0749cfe835 100644
--- a/gcc/ada/lib-xref.ads
+++ b/gcc/ada/lib-xref.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1998-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2011, 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- --
@@ -44,7 +44,7 @@ package Lib.Xref is
-- This header precedes xref information (entities/references from
-- the unit), identified by dependency number and file name. The
-- dependency number is the index into the generated D lines and
- -- is ones origin (i.e. 2 = reference to second generated D line).
+ -- its origin is one (i.e. 2 = reference to second generated D line).
-- Note that the filename here will reflect the original name if
-- a Source_Reference pragma was encountered (since all line number
@@ -52,7 +52,7 @@ package Lib.Xref is
-- The lines following the header look like
- -- line type col level entity renameref instref typeref overref ref ref
+ -- line type col level entity renameref instref typeref overref ref ref
-- line is the line number of the referenced entity. The name of
-- the entity starts in column col. Columns are numbered from one,
@@ -69,7 +69,7 @@ package Lib.Xref is
-- level is a single character that separates the col and
-- entity fields. It is an asterisk (*) for a top level library
- -- entity that is publicly visible, as well for an entity declared
+ -- entity that is publicly visible, as well as for an entity declared
-- in the visible part of a generic package, the plus sign (+) for
-- a C/C++ static entity, and space otherwise.
@@ -172,9 +172,11 @@ package Lib.Xref is
-- b = body entity
-- c = completion of private or incomplete type
-- d = discriminant of type
+ -- D = object definition
-- e = end of spec
-- H = abstract type
-- i = implicit reference
+ -- I = object definition with initialization
-- k = implicit reference to parent unit in child unit
-- l = label on END line
-- m = modification
@@ -567,6 +569,134 @@ package Lib.Xref is
-- y abstract function entry or entry family
-- z generic formal parameter (unused)
+ -------------------------------------------------------------
+ -- Format of Local Cross-Reference Information in ALI File --
+ -------------------------------------------------------------
+
+ -- Local cross-reference sections follow the cross-reference section in an
+ -- ALI file, so that they need not be read by gnatbind, gnatmake etc.
+
+ -- A local cross-reference section has a header of the form
+
+ -- S line type col entity
+
+ -- These precisely define a subprogram or package, with the same
+ -- components as described for cross-reference sections.
+
+ -- These sections are grouped in chapters for each unit introduced by
+
+ -- F dependency-number filename
+
+ -- Each section groups a number of cross-reference sub-sections introduced
+ -- by
+
+ -- X dependency-number filename
+
+ -- Inside each cross-reference sub-section, there are a number of
+ -- references like
+
+ -- line type col entity ref ref ...
+
+ -----------------------------------
+ -- Local-Reference Entity Filter --
+ -----------------------------------
+
+ Lref_Entity_Status : array (Entity_Kind) of Boolean :=
+ (E_Void => False,
+ E_Variable => True,
+ E_Component => False,
+ E_Constant => True,
+ E_Discriminant => False,
+
+ E_Loop_Parameter => True,
+ E_In_Parameter => True,
+ E_Out_Parameter => True,
+ E_In_Out_Parameter => True,
+ E_Generic_In_Out_Parameter => False,
+
+ E_Generic_In_Parameter => False,
+ E_Named_Integer => False,
+ E_Named_Real => False,
+ E_Enumeration_Type => False,
+ E_Enumeration_Subtype => False,
+
+ E_Signed_Integer_Type => False,
+ E_Signed_Integer_Subtype => False,
+ E_Modular_Integer_Type => False,
+ E_Modular_Integer_Subtype => False,
+ E_Ordinary_Fixed_Point_Type => False,
+
+ E_Ordinary_Fixed_Point_Subtype => False,
+ E_Decimal_Fixed_Point_Type => False,
+ E_Decimal_Fixed_Point_Subtype => False,
+ E_Floating_Point_Type => False,
+ E_Floating_Point_Subtype => False,
+
+ E_Access_Type => False,
+ E_Access_Subtype => False,
+ E_Access_Attribute_Type => False,
+ E_Allocator_Type => False,
+ E_General_Access_Type => False,
+
+ E_Access_Subprogram_Type => False,
+ E_Access_Protected_Subprogram_Type => False,
+ E_Anonymous_Access_Subprogram_Type => False,
+ E_Anonymous_Access_Protected_Subprogram_Type => False,
+ E_Anonymous_Access_Type => False,
+
+ E_Array_Type => False,
+ E_Array_Subtype => False,
+ E_String_Type => False,
+ E_String_Subtype => False,
+ E_String_Literal_Subtype => False,
+
+ E_Class_Wide_Type => False,
+ E_Class_Wide_Subtype => False,
+ E_Record_Type => False,
+ E_Record_Subtype => False,
+ E_Record_Type_With_Private => False,
+
+ E_Record_Subtype_With_Private => False,
+ E_Private_Type => False,
+ E_Private_Subtype => False,
+ E_Limited_Private_Type => False,
+ E_Limited_Private_Subtype => False,
+
+ E_Incomplete_Type => False,
+ E_Incomplete_Subtype => False,
+ E_Task_Type => False,
+ E_Task_Subtype => False,
+ E_Protected_Type => False,
+
+ E_Protected_Subtype => False,
+ E_Exception_Type => False,
+ E_Subprogram_Type => False,
+ E_Enumeration_Literal => False,
+ E_Function => True,
+
+ E_Operator => True,
+ E_Procedure => True,
+ E_Entry => False,
+ E_Entry_Family => False,
+ E_Block => False,
+
+ E_Entry_Index_Parameter => False,
+ E_Exception => False,
+ E_Generic_Function => False,
+ E_Generic_Package => False,
+ E_Generic_Procedure => False,
+
+ E_Label => False,
+ E_Loop => False,
+ E_Return_Statement => False,
+ E_Package => False,
+
+ E_Package_Body => False,
+ E_Protected_Object => False,
+ E_Protected_Body => False,
+ E_Task_Body => False,
+ E_Subprogram_Body => False);
+
--------------------------------------
-- Handling of Imported Subprograms --
--------------------------------------
@@ -611,17 +741,8 @@ package Lib.Xref is
-- This procedure is called to record a reference. N is the location
-- of the reference and E is the referenced entity. Typ is one of:
--
- -- 'b' body entity
- -- 'c' completion of incomplete or private type (see below)
- -- 'e' end of construct
- -- 'i' implicit reference
- -- 'l' label on end line
- -- 'm' modification
- -- 'p' primitive operation
- -- 'r' standard reference
- -- 't' end of body
- -- 'x' type extension
- -- ' ' dummy reference (see below)
+ -- a character already described in the description of ref entries above
+ -- ' ' for dummy reference (see below)
--
-- Note: all references to incomplete or private types are to the
-- original (incomplete or private type) declaration. The full
@@ -675,6 +796,9 @@ package Lib.Xref is
procedure Output_References;
-- Output references to the current ali file
+ procedure Output_Local_References;
+ -- Output references in each subprogram of the current ali file
+
procedure Initialize;
-- Initialize internal tables
diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb
index e46c87223f5d..0e5c3db3cf00 100755
--- a/gcc/ada/sem_aux.adb
+++ b/gcc/ada/sem_aux.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, 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- --
@@ -180,10 +180,16 @@ package body Sem_Aux is
if No (S) then
return Standard_Standard;
- -- Quit if we get to standard or a dynamic scope
+ -- Quit if we get to standard or a dynamic scope. We must also
+ -- handle enclosing scopes that have a full view; required to
+ -- locate enclosing scopes that are synchronized private types
+ -- whose full view is a task type.
elsif S = Standard_Standard
or else Is_Dynamic_Scope (S)
+ or else (Is_Private_Type (S)
+ and then Present (Full_View (S))
+ and then Is_Dynamic_Scope (Full_View (S)))
then
return S;
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index ca160188bf68..d30d4445f76b 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, 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- --
@@ -3701,6 +3701,10 @@ package body Sem_Ch3 is
if Has_Aspects (N) then
Analyze_Aspect_Specifications (N, Id);
end if;
+
+ if ALFA_Mode and then Present (Expression (Original_Node (N))) then
+ Generate_Reference (Id, Id, 'I');
+ end if;
end Analyze_Object_Declaration;
---------------------------
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 4f54170472c5..01d6aee58691 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, 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- --
@@ -7816,7 +7816,7 @@ package body Sem_Prag is
end if;
if (Present (Parameter_Types)
- or else
+ or else
Present (Result_Type))
and then
Present (Source_Location)
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index f8e19a1b0e52..ef406e1243c5 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -5751,9 +5751,9 @@ package body Sem_Res is
-- Check_Formal_Restriction ("function not inherited", N);
-- end if;
- -- Implement rule in 12.5.1 (23.3/2) : in an instance, if the actual
- -- is class-wide and the call dispatches on result in a context that
- -- does not provide a tag, the call raises Program_Error.
+ -- Implement rule in 12.5.1 (23.3/2): In an instance, if the actual is
+ -- class-wide and the call dispatches on result in a context that does
+ -- not provide a tag, the call raises Program_Error.
if Nkind (N) = N_Function_Call
and then In_Instance
@@ -5762,11 +5762,10 @@ package body Sem_Res is
and then Has_Controlling_Result (Nam)
and then Nkind (Parent (N)) = N_Object_Declaration
then
-
- -- verify that none of the formals are controlling.
+ -- Verify that none of the formals are controlling
declare
- Call_OK : Boolean := False;
+ Call_OK : Boolean := False;
F : Entity_Id;
begin
@@ -5776,6 +5775,7 @@ package body Sem_Res is
Call_OK := True;
exit;
end if;
+
Next_Formal (F);
end loop;
--
GitLab