From bf7f5966ca276c3c1b650c9132e913a0966766ce Mon Sep 17 00:00:00 2001 From: charlet Date: Tue, 2 Aug 2011 14:50:56 +0000 Subject: [PATCH] 2011-08-02 Robert Dewar * sem_res.adb: Minor reformatting. * sem_prag.adb: Minor reformatting. 2011-08-02 Javier Miranda * 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 * 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 git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@177168 138bc75d-0d04-0410-961f-82ee72b054a4 --- 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 93d8439..0890b26 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,64 @@ +2011-08-02 Robert Dewar + + * sem_res.adb: Minor reformatting. + * sem_prag.adb: Minor reformatting. + +2011-08-02 Javier Miranda + + * 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 + + * 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 * 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 7ed2a3f..f89263c 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! (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 384a2d0..586904b 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 b9af60e..8a842fb 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 d2c7725..8063601 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 9eff234..4f0fc0f 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! (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! (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, , ); + 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, , ); + 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 70d77c8..074c658 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 639d938..f440b22 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 d1e442a..ecabb39 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 4c4cef0..d44f1b8 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 9fb8b2d..1d0749c 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 e46c872..0e5c3db 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 ca16018..d30d444 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 4f54170..01d6aee 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 f8e19a1..ef406e1 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; -- 2.7.4