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



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@177168 138bc75d-0d04-0410-961f-82ee72b054a4

15 files changed, 1107 insertions, 147 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 93d8439ac16..0890b264a07 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,64 @@
+2011-08-02  Robert Dewar  <dewar@adacore.com>
+
+	* sem_res.adb: Minor reformatting.
+	* sem_prag.adb: Minor reformatting.
+
+2011-08-02  Javier Miranda  <miranda@adacore.com>
+
+	* exp_atag.adb, exp_atags.ads
+	(Build_Common_Dispatching_Select_Statement): Replace argument DT_Ptr
+	by the tagged type Entity. Required to use this routine in the VM
+	targets since we do not have available the Tag entity in the VM
+	platforms.
+	* exp_ch6.adb
+	(Expand_N_Subprogram_Body): Do not invoke Build_VM_TSDs if package
+	Ada.Tags has not been previously loaded.
+	* exp_ch7.adb
+	(Expand_N_Package_Declaration, Expand_N_Package_Body): Do not invoke
+	Build_VM_TSDs if package Ada.Tags has not been previously loaded.
+	* sem_aux.adb
+	(Enclosing_Dynamic_Scope): Add missing support to handle the full
+	view of enclosing scopes. Required to handle enclosing scopes that
+	are synchronized types whose full view is a task type.
+	* exp_disp.adb
+	(Build_VM_TSDs): Minor code improvement to avoid generating and
+	analyzing lists with empty nodes.
+	(Make_Disp_Asynchronous_Select_Body): Add support for VM targets.
+	(Make_Disp_Conditional_Select_Body): Add support for VM targets.
+	(Make_Disp_Get_Prim_Op_Kind): Add support for VM targets.
+	(Make_Disp_Timed_Select_Body): Add support for VM targets.
+	(Make_Select_Specific_Data_Table): Add support for VM targets.
+	(Make_VM_TSD): Generate code to initialize the SSD structure of
+	the TSD.
+
+2011-08-02  Yannick Moy  <moy@adacore.com>
+
+	* lib-writ.adb (Write_ALI): when ALFA mode is set, write local
+	cross-references section in ALI.
+	* lib-xref.adb, lib-xref.ads (Xref_Entry): add components Sub
+	(enclosing subprogram), Slc (location of Sub) and Sun (unit number of
+	Sub).
+	(Enclosing_Subprogram_Or_Package): new function to return the enclosing
+	subprogram or package entity of a node
+	(Is_Local_Reference_Type): new function returns True for references
+	selected in local cross-references.
+	(Lt): function extracted from Lt in Output_References
+	(Write_Entity_Name): function extracted from Output_References
+	(Generate_Definition): generate reference with type 'D' for definition
+	of objects (object declaration and parameter specification), with
+	appropriate locations and units, for use in local cross-references.
+	(Generate_Reference): update fields Sub, Slc and Sun. Keep newly created
+	references of type 'I' for initialization in object definition.
+	(Output_References): move part of function Lt and procedure
+	Write_Entity_Name outside of the body. Ignore references of types 'D'
+	and 'I' introduced for local cross-references.
+	(Output_Local_References): new procedure to output the local
+	cross-references sections.
+	(Lref_Entity_Status): new array defining whether an entity is a local
+	* sem_ch3.adb (Analyze_Object_Declaration): call Generate_Reference
+	with 'I' type when initialization expression is present.
+	* get_scos.adb, get_scos.ads: Correct comments and typos
+
 2011-08-02  Javier Miranda  <miranda@adacore.com>
 
 	* exp_ch6.adb (Expand_N_Subprogram_Body): Enable generation of TSDs in
diff --git a/gcc/ada/exp_atag.adb b/gcc/ada/exp_atag.adb
index 7ed2a3f5f84..f89263c50c0 100644
--- a/gcc/ada/exp_atag.adb
+++ b/gcc/ada/exp_atag.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 2006-2010, Free Software Foundation, Inc.         --
+--          Copyright (C) 2006-2011, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -31,6 +31,7 @@ with Exp_Util; use Exp_Util;
 with Namet;    use Namet;
 with Nlists;   use Nlists;
 with Nmake;    use Nmake;
+with Opt;      use Opt;
 with Rtsfind;  use Rtsfind;
 with Sinfo;    use Sinfo;
 with Sem_Aux;  use Sem_Aux;
@@ -71,9 +72,11 @@ package body Exp_Atag is
 
    procedure Build_Common_Dispatching_Select_Statements
      (Loc    : Source_Ptr;
-      DT_Ptr : Entity_Id;
+      Typ    : Entity_Id;
       Stmts  : List_Id)
    is
+      Tag_Node : Node_Id;
+
    begin
       --  Generate:
       --    C := get_prim_op_kind (tag! (<type>VP), S);
@@ -81,6 +84,19 @@ package body Exp_Atag is
       --  where C is the out parameter capturing the call kind and S is the
       --  dispatch table slot number.
 
+      if Tagged_Type_Expansion then
+         Tag_Node :=
+           Unchecked_Convert_To (RTE (RE_Tag),
+             New_Reference_To
+              (Node (First_Elmt (Access_Disp_Table (Typ))), Loc));
+
+      else
+         Tag_Node :=
+           Make_Attribute_Reference (Loc,
+             Prefix => New_Reference_To (Typ, Loc),
+             Attribute_Name => Name_Tag);
+      end if;
+
       Append_To (Stmts,
         Make_Assignment_Statement (Loc,
           Name => Make_Identifier (Loc, Name_uC),
@@ -88,8 +104,7 @@ package body Exp_Atag is
             Make_Function_Call (Loc,
               Name => New_Occurrence_Of (RTE (RE_Get_Prim_Op_Kind), Loc),
               Parameter_Associations => New_List (
-                Unchecked_Convert_To (RTE (RE_Tag),
-                  New_Reference_To (DT_Ptr, Loc)),
+                Tag_Node,
                 Make_Identifier (Loc, Name_uS)))));
 
       --  Generate:
diff --git a/gcc/ada/exp_atag.ads b/gcc/ada/exp_atag.ads
index 384a2d0baa3..586904bd381 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 b9af60ead86..8a842fba5b2 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 d2c7725dec1..8063601256b 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 9eff2347e80..4f0fc0fbe87 100644
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -474,7 +474,7 @@ package body Exp_Disp is
    -------------------
 
    procedure Build_VM_TSDs (N : Entity_Id) is
-      Target_List : List_Id;
+      Target_List : List_Id := No_List;
 
       procedure Build_TSDs (List : List_Id);
       --  Build the static dispatch table of tagged types found in the list of
@@ -538,6 +538,10 @@ package body Exp_Disp is
                   null;
 
                else
+                  if No (Target_List) then
+                     Target_List := New_List;
+                  end if;
+
                   Append_List_To (Target_List,
                     Make_VM_TSD (Defining_Entity (D)));
                end if;
@@ -552,9 +556,9 @@ package body Exp_Disp is
       ------------------------
 
       procedure Build_Package_TSDs (N : Node_Id) is
-         Spec       : constant Node_Id   := Specification (N);
-         Vis_Decls  : constant List_Id   := Visible_Declarations (Spec);
-         Priv_Decls : constant List_Id   := Private_Declarations (Spec);
+         Spec       : constant Node_Id := Specification (N);
+         Vis_Decls  : constant List_Id := Visible_Declarations (Spec);
+         Priv_Decls : constant List_Id := Private_Declarations (Spec);
 
       begin
          if Present (Priv_Decls) then
@@ -571,6 +575,7 @@ package body Exp_Disp is
    begin
       if not Expander_Active
         or else No_Run_Time_Mode
+        or else Tagged_Type_Expansion
         or else not RTE_Available (RE_Type_Specific_Data)
       then
          return;
@@ -583,25 +588,33 @@ package body Exp_Disp is
             Priv_Decls : constant List_Id := Private_Declarations (Spec);
 
          begin
-            Target_List := New_List;
             Build_Package_TSDs (N);
-            Analyze_List (Target_List);
 
-            if Present (Priv_Decls)
-              and then Is_Non_Empty_List (Priv_Decls)
-            then
-               Append_List (Target_List, Priv_Decls);
-            else
-               Append_List (Target_List, Vis_Decls);
+            if Present (Target_List) then
+               Analyze_List (Target_List);
+
+               if Present (Priv_Decls)
+                  and then Is_Non_Empty_List (Priv_Decls)
+               then
+                  Append_List (Target_List, Priv_Decls);
+               else
+                  Append_List (Target_List, Vis_Decls);
+               end if;
             end if;
          end;
 
       elsif Nkind_In (N, N_Package_Body, N_Subprogram_Body) then
          if Is_Non_Empty_List (Declarations (N)) then
-            Target_List := New_List;
-            Build_TSDs   (Declarations (N));
-            Analyze_List (Target_List);
-            Append_List  (Target_List, Declarations (N));
+            Build_TSDs (Declarations (N));
+
+            if Nkind (N) = N_Subprogram_Body then
+               Build_TSDs (Statements (Handled_Statement_Sequence (N)));
+            end if;
+
+            if Present (Target_List) then
+               Analyze_List (Target_List);
+               Append_List  (Target_List, Declarations (N));
+            end if;
          end if;
       end if;
    end Build_VM_TSDs;
@@ -2209,10 +2222,10 @@ package body Exp_Disp is
       Com_Block : Entity_Id;
       Conc_Typ  : Entity_Id           := Empty;
       Decls     : constant List_Id    := New_List;
-      DT_Ptr    : Entity_Id;
       Loc       : constant Source_Ptr := Sloc (Typ);
       Obj_Ref   : Node_Id;
       Stmts     : constant List_Id    := New_List;
+      Tag_Node  : Node_Id;
 
    begin
       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
@@ -2231,8 +2244,6 @@ package body Exp_Disp is
                  New_List (Make_Null_Statement (Loc))));
       end if;
 
-      DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
-
       if Is_Concurrent_Record_Type (Typ) then
          Conc_Typ := Corresponding_Concurrent_Type (Typ);
 
@@ -2243,6 +2254,18 @@ package body Exp_Disp is
          --  where I will be used to capture the entry index of the primitive
          --  wrapper at position S.
 
+         if Tagged_Type_Expansion then
+            Tag_Node :=
+              Unchecked_Convert_To (RTE (RE_Tag),
+                New_Reference_To
+                  (Node (First_Elmt (Access_Disp_Table (Typ))), Loc));
+         else
+            Tag_Node :=
+              Make_Attribute_Reference (Loc,
+                Prefix => New_Reference_To (Typ, Loc),
+                Attribute_Name => Name_Tag);
+         end if;
+
          Append_To (Decls,
            Make_Object_Declaration (Loc,
              Defining_Identifier =>
@@ -2255,8 +2278,7 @@ package body Exp_Disp is
                    New_Reference_To (RTE (RE_Get_Entry_Index), Loc),
                  Parameter_Associations =>
                    New_List (
-                     Unchecked_Convert_To (RTE (RE_Tag),
-                       New_Reference_To (DT_Ptr, Loc)),
+                     Tag_Node,
                      Make_Identifier (Loc, Name_uS)))));
 
          if Ekind (Conc_Typ) = E_Protected_Type then
@@ -2553,9 +2575,9 @@ package body Exp_Disp is
       Blk_Nam  : Entity_Id;
       Conc_Typ : Entity_Id           := Empty;
       Decls    : constant List_Id    := New_List;
-      DT_Ptr   : Entity_Id;
       Obj_Ref  : Node_Id;
       Stmts    : constant List_Id    := New_List;
+      Tag_Node : Node_Id;
 
    begin
       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
@@ -2574,8 +2596,6 @@ package body Exp_Disp is
                  New_List (Make_Null_Statement (Loc))));
       end if;
 
-      DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
-
       if Is_Concurrent_Record_Type (Typ) then
          Conc_Typ := Corresponding_Concurrent_Type (Typ);
 
@@ -2603,7 +2623,7 @@ package body Exp_Disp is
          --       return;
          --    end if;
 
-         Build_Common_Dispatching_Select_Statements (Loc, DT_Ptr, Stmts);
+         Build_Common_Dispatching_Select_Statements (Loc, Typ, Stmts);
 
          --  Generate:
          --    Bnn : Communication_Block;
@@ -2624,6 +2644,19 @@ package body Exp_Disp is
 
          --  I is the entry index and S is the dispatch table slot
 
+         if Tagged_Type_Expansion then
+            Tag_Node :=
+              Unchecked_Convert_To (RTE (RE_Tag),
+                New_Reference_To
+                  (Node (First_Elmt (Access_Disp_Table (Typ))), Loc));
+
+         else
+            Tag_Node :=
+              Make_Attribute_Reference (Loc,
+                Prefix => New_Reference_To (Typ, Loc),
+                Attribute_Name => Name_Tag);
+         end if;
+
          Append_To (Stmts,
            Make_Assignment_Statement (Loc,
              Name => Make_Identifier (Loc, Name_uI),
@@ -2633,8 +2666,7 @@ package body Exp_Disp is
                    New_Reference_To (RTE (RE_Get_Entry_Index), Loc),
                  Parameter_Associations =>
                    New_List (
-                     Unchecked_Convert_To (RTE (RE_Tag),
-                       New_Reference_To (DT_Ptr, Loc)),
+                     Tag_Node,
                      Make_Identifier (Loc, Name_uS)))));
 
          if Ekind (Conc_Typ) = E_Protected_Type then
@@ -2848,8 +2880,8 @@ package body Exp_Disp is
    function Make_Disp_Get_Prim_Op_Kind_Body
      (Typ : Entity_Id) return Node_Id
    is
-      Loc    : constant Source_Ptr := Sloc (Typ);
-      DT_Ptr : Entity_Id;
+      Loc      : constant Source_Ptr := Sloc (Typ);
+      Tag_Node : Node_Id;
 
    begin
       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
@@ -2866,14 +2898,25 @@ package body Exp_Disp is
                  New_List (Make_Null_Statement (Loc))));
       end if;
 
-      DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
-
       --  Generate:
       --    C := get_prim_op_kind (tag! (<type>VP), S);
 
       --  where C is the out parameter capturing the call kind and S is the
       --  dispatch table slot number.
 
+      if Tagged_Type_Expansion then
+         Tag_Node :=
+           Unchecked_Convert_To (RTE (RE_Tag),
+             New_Reference_To
+              (Node (First_Elmt (Access_Disp_Table (Typ))), Loc));
+
+      else
+         Tag_Node :=
+           Make_Attribute_Reference (Loc,
+             Prefix => New_Reference_To (Typ, Loc),
+             Attribute_Name => Name_Tag);
+      end if;
+
       return
         Make_Subprogram_Body (Loc,
           Specification =>
@@ -2891,9 +2934,8 @@ package body Exp_Disp is
                       Name =>
                         New_Reference_To (RTE (RE_Get_Prim_Op_Kind), Loc),
                       Parameter_Associations => New_List (
-                        Unchecked_Convert_To (RTE (RE_Tag),
-                          New_Reference_To (DT_Ptr, Loc)),
-                          Make_Identifier (Loc, Name_uS)))))));
+                        Tag_Node,
+                        Make_Identifier (Loc, Name_uS)))))));
    end Make_Disp_Get_Prim_Op_Kind_Body;
 
    -------------------------------------
@@ -3380,9 +3422,9 @@ package body Exp_Disp is
       Loc      : constant Source_Ptr := Sloc (Typ);
       Conc_Typ : Entity_Id           := Empty;
       Decls    : constant List_Id    := New_List;
-      DT_Ptr   : Entity_Id;
       Obj_Ref  : Node_Id;
       Stmts    : constant List_Id    := New_List;
+      Tag_Node : Node_Id;
 
    begin
       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
@@ -3401,8 +3443,6 @@ package body Exp_Disp is
                  New_List (Make_Null_Statement (Loc))));
       end if;
 
-      DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
-
       if Is_Concurrent_Record_Type (Typ) then
          Conc_Typ := Corresponding_Concurrent_Type (Typ);
 
@@ -3430,13 +3470,26 @@ package body Exp_Disp is
          --       return;
          --    end if;
 
-         Build_Common_Dispatching_Select_Statements (Loc, DT_Ptr, Stmts);
+         Build_Common_Dispatching_Select_Statements (Loc, Typ, Stmts);
 
          --  Generate:
          --    I := Get_Entry_Index (tag! (<type>VP), S);
 
          --  I is the entry index and S is the dispatch table slot
 
+         if Tagged_Type_Expansion then
+            Tag_Node :=
+              Unchecked_Convert_To (RTE (RE_Tag),
+                New_Reference_To
+                  (Node (First_Elmt (Access_Disp_Table (Typ))), Loc));
+
+         else
+            Tag_Node :=
+              Make_Attribute_Reference (Loc,
+                Prefix => New_Reference_To (Typ, Loc),
+                Attribute_Name => Name_Tag);
+         end if;
+
          Append_To (Stmts,
            Make_Assignment_Statement (Loc,
              Name       => Make_Identifier (Loc, Name_uI),
@@ -3446,8 +3499,7 @@ package body Exp_Disp is
                    New_Reference_To (RTE (RE_Get_Entry_Index), Loc),
                  Parameter_Associations =>
                    New_List (
-                     Unchecked_Convert_To (RTE (RE_Tag),
-                       New_Reference_To (DT_Ptr, Loc)),
+                     Tag_Node,
                      Make_Identifier (Loc, Name_uS)))));
 
          --  Protected case
@@ -6258,16 +6310,21 @@ package body Exp_Disp is
       Loc              : constant Source_Ptr := Sloc (Typ);
       Result           : constant List_Id := New_List;
       AI               : Elmt_Id;
-      I_Depth          : Nat := 0; -- why initialized here ???
+      I_Depth          : Nat;
       Iface_Table_Node : Node_Id;
-      Num_Ifaces       : Nat := 0; -- why initialized here ???
+      Nb_Prim          : Nat;
+      Num_Ifaces       : Nat;
       TSD_Aggr_List    : List_Id;
       Typ_Ifaces       : Elist_Id;
       TSD_Tags_List    : List_Id;
 
       Tname    : constant Name_Id := Chars (Typ);
+      Name_SSD : constant Name_Id :=
+                   New_External_Name (Tname, 'S', Suffix_Index => -1);
       Name_TSD : constant Name_Id :=
                    New_External_Name (Tname, 'B', Suffix_Index => -1);
+      SSD      : constant Entity_Id :=
+                   Make_Defining_Identifier (Loc, Name_SSD);
       TSD      : constant Entity_Id :=
                    Make_Defining_Identifier (Loc, Name_TSD);
    begin
@@ -6359,6 +6416,7 @@ package body Exp_Disp is
 
          Collect_Interfaces (Typ, Typ_Ifaces);
 
+         Num_Ifaces := 0;
          AI := First_Elmt (Typ_Ifaces);
          while Present (AI) loop
             Num_Ifaces := Num_Ifaces + 1;
@@ -6420,6 +6478,68 @@ package body Exp_Disp is
          Append_To (TSD_Aggr_List, Iface_Table_Node);
       end if;
 
+      --  Generate the Select Specific Data table for synchronized types that
+      --  implement synchronized interfaces. The size of the table is
+      --  constrained by the number of non-predefined primitive operations.
+
+      --  Count the non-predefined primitive operations
+
+      Nb_Prim := 0;
+
+      declare
+         Prim_Elmt : Elmt_Id;
+         Prim      : Entity_Id;
+      begin
+         Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
+         while Present (Prim_Elmt) loop
+            Prim := Node (Prim_Elmt);
+
+            if not (Is_Predefined_Dispatching_Operation (Prim)
+                      or else Is_Predefined_Dispatching_Alias (Prim))
+            then
+               Nb_Prim := Nb_Prim + 1;
+            end if;
+
+            Next_Elmt (Prim_Elmt);
+         end loop;
+      end;
+
+      if RTE_Record_Component_Available (RE_SSD) then
+         if Ada_Version >= Ada_2005
+           and then Has_DT (Typ)
+           and then Is_Concurrent_Record_Type (Typ)
+           and then Has_Interfaces (Typ)
+           and then Nb_Prim > 0
+           and then not Is_Abstract_Type (Typ)
+           and then not Is_Controlled (Typ)
+           and then not Restriction_Active (No_Dispatching_Calls)
+           and then not Restriction_Active (No_Select_Statements)
+         then
+            Append_To (Result,
+              Make_Object_Declaration (Loc,
+                Defining_Identifier => SSD,
+                Aliased_Present     => True,
+                Object_Definition   =>
+                  Make_Subtype_Indication (Loc,
+                    Subtype_Mark => New_Reference_To (
+                      RTE (RE_Select_Specific_Data), Loc),
+                    Constraint   =>
+                      Make_Index_Or_Discriminant_Constraint (Loc,
+                        Constraints => New_List (
+                          Make_Integer_Literal (Loc, Nb_Prim))))));
+
+            --  This table is initialized by Make_Select_Specific_Data_Table,
+            --  which calls Set_Entry_Index and Set_Prim_Op_Kind.
+
+            Append_To (TSD_Aggr_List,
+              Make_Attribute_Reference (Loc,
+                Prefix => New_Reference_To (SSD, Loc),
+                Attribute_Name => Name_Unchecked_Access));
+         else
+            Append_To (TSD_Aggr_List, Make_Null (Loc));
+         end if;
+      end if;
+
       --  Initialize the table of ancestor tags. In case of interface types
       --  this table is not needed.
 
@@ -6510,6 +6630,21 @@ package body Exp_Disp is
               Prefix => New_Reference_To (TSD, Loc),
               Attribute_Name => Name_Unrestricted_Access))));
 
+      --  Populate the two auxiliary tables used for dispatching asynchronous,
+      --  conditional and timed selects for synchronized types that implement
+      --  a limited interface. Skip this step in Ravenscar profile or when
+      --  general dispatching is forbidden.
+
+      if Ada_Version >= Ada_2005
+        and then Is_Concurrent_Record_Type (Typ)
+        and then Has_Interfaces (Typ)
+        and then not Restriction_Active (No_Dispatching_Calls)
+        and then not Restriction_Active (No_Select_Statements)
+      then
+         Append_List_To (Result,
+           Make_Select_Specific_Data_Table (Typ));
+      end if;
+
       return Result;
    end Make_VM_TSD;
 
@@ -6525,7 +6660,6 @@ package body Exp_Disp is
 
       Conc_Typ  : Entity_Id;
       Decls     : List_Id;
-      DT_Ptr    : Entity_Id;
       Prim      : Entity_Id;
       Prim_Als  : Entity_Id;
       Prim_Elmt : Elmt_Id;
@@ -6567,13 +6701,15 @@ package body Exp_Disp is
          return Uint_0;
       end Find_Entry_Index;
 
+      --  Local variables
+
+      Tag_Node : Node_Id;
+
    --  Start of processing for Make_Select_Specific_Data_Table
 
    begin
       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
 
-      DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
-
       if Present (Corresponding_Concurrent_Type (Typ)) then
          Conc_Typ := Corresponding_Concurrent_Type (Typ);
 
@@ -6631,11 +6767,23 @@ package body Exp_Disp is
                --  type. Generate:
                --    Ada.Tags.Set_Prim_Op_Kind (DT_Ptr, <position>, <kind>);
 
+               if Tagged_Type_Expansion then
+                  Tag_Node :=
+                    New_Reference_To
+                     (Node (First_Elmt (Access_Disp_Table (Typ))), Loc);
+
+               else
+                  Tag_Node :=
+                    Make_Attribute_Reference (Loc,
+                      Prefix => New_Reference_To (Typ, Loc),
+                      Attribute_Name => Name_Tag);
+               end if;
+
                Append_To (Assignments,
                  Make_Procedure_Call_Statement (Loc,
                    Name => New_Reference_To (RTE (RE_Set_Prim_Op_Kind), Loc),
                    Parameter_Associations => New_List (
-                     New_Reference_To (DT_Ptr, Loc),
+                     Tag_Node,
                      Make_Integer_Literal (Loc, Prim_Pos),
                      Prim_Op_Kind (Alias (Prim), Typ))));
 
@@ -6653,12 +6801,23 @@ package body Exp_Disp is
                   --    Ada.Tags.Set_Entry_Index
                   --      (DT_Ptr, <position>, <index>);
 
+                  if Tagged_Type_Expansion then
+                     Tag_Node :=
+                       New_Reference_To
+                        (Node (First_Elmt (Access_Disp_Table (Typ))), Loc);
+                  else
+                     Tag_Node :=
+                       Make_Attribute_Reference (Loc,
+                         Prefix => New_Reference_To (Typ, Loc),
+                         Attribute_Name => Name_Tag);
+                  end if;
+
                   Append_To (Assignments,
                     Make_Procedure_Call_Statement (Loc,
                       Name =>
                         New_Reference_To (RTE (RE_Set_Entry_Index), Loc),
                       Parameter_Associations => New_List (
-                        New_Reference_To (DT_Ptr, Loc),
+                        Tag_Node,
                         Make_Integer_Literal (Loc, Prim_Pos),
                         Make_Integer_Literal (Loc,
                           Find_Entry_Index (Wrapped_Entity (Prim_Als))))));
diff --git a/gcc/ada/get_scos.adb b/gcc/ada/get_scos.adb
index 70d77c80b6a..074c6587854 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 639d938bbfe..f440b2238cf 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 d1e442a32b0..ecabb393f7f 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 4c4cef0f3a9..d44f1b8eccf 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 9fb8b2df565..1d0749cfe83 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 e46c87223f5..0e5c3db3cf0 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 ca160188bf6..d30d4445f76 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 4f54170472c..01d6aee5869 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 f8e19a1b0e5..ef406e1243c 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;