Skip to content

R
riscv-gcc-1
Commit e8374e7a by Arnaud Charlet
Options

[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
parent 1f6439e3
Showing with 1075 additions and 115 deletions
gcc/ada/ChangeLog
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
......
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:
......
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- --
......@@ -36,7 +36,7 @@ package Exp_Atag is
procedure Build_Common_Dispatching_Select_Statements
(Loc : Source_Ptr;
DT_Ptr : Entity_Id;
Typ : Entity_Id;
Stmts : List_Id);
-- Ada 2005 (AI-345): Generate statements that are common between timed,
-- asynchronous, and conditional select expansion.
......
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;
......
gcc/ada/exp_ch7.adb
......@@ -1560,9 +1560,17 @@ package body Exp_Ch7 is
-- we must generate the corresponding Type Specific Data record.
elsif Unit (Cunit (Main_Unit)) = N then
-- 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;
Build_Task_Activation_Call (N);
Pop_Scope;
......@@ -1670,9 +1678,15 @@ 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);
......@@ -1688,6 +1702,7 @@ package body Exp_Ch7 is
Pop_Scope;
end if;
end if;
end if;
-- Note: it is not necessary to worry about generating a subprogram
-- descriptor, since the only way to get exception handlers into a
......
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;
......@@ -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,8 +588,9 @@ package body Exp_Disp is
Priv_Decls : constant List_Id := Private_Declarations (Spec);
begin
Target_List := New_List;
Build_Package_TSDs (N);
if Present (Target_List) then
Analyze_List (Target_List);
if Present (Priv_Decls)
......@@ -594,16 +600,23 @@ package body Exp_Disp is
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));
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
......@@ -2849,7 +2881,7 @@ package body Exp_Disp is
(Typ : Entity_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Typ);
DT_Ptr : Entity_Id;
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,8 +2934,7 @@ 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)),
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))))));
......
gcc/ada/get_scos.adb
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......
gcc/ada/get_scos.ads
......@@ -6,7 +6,7 @@
-- --
-- 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.
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!
......
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;
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).Typ := ' ';
Xrefs.Table (Indx).Eun := Get_Source_Unit (Loc);
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);
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;
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
......@@ -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
......
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;
......
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;
---------------------------
......
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- --
......
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,8 +5762,7 @@ 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;
......@@ -5776,6 +5775,7 @@ package body Sem_Res is
Call_OK := True;
exit;
end if;
Next_Formal (F);
end loop;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment