exp_ch3.adb (Build_Init_Statements): Alphabetize local variables.

2008-05-26  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_ch3.adb (Build_Init_Statements): Alphabetize local variables.
	Create the statements which map a string name to protected or task
	entry indix.

	* exp_ch9.adb: Add with and use clause for Stringt.
	Minor code reformatting.
	(Build_Entry_Names): New routine.
	(Make_Initialize_Protection, Make_Task_Create_Call): Generate a value
	for flag Build_Entry_Names which controls the allocation of the data
	structure for the string names of entries.

	* exp_ch9.ads (Build_Entry_Names): New subprogram.

	* exp_util.adb (Entry_Names_OK): New function.

	* exp_util.ads (Entry_Names_OK): New function.

	* rtsfind.ads: Add RO_PE_Set_Entry_Name and RO_TS_Set_Entry_Name to
	enumerations RE_Id and RE_Unit_Table.

	* s-taskin.adb Add with and use clause for Ada.Unchecked_Deallocation.
	(Free_Entry_Names_Array): New routine.

	* s-taskin.ads: Comment reformatting.
	Add types String_Access, Entry_Names_Array, Entry_Names_Array_Access.
	Add component Entry_Names to record Ada_Task_Control_Block.
	(Free_Entry_Names_Array): New routine.

	* s-tassta.adb (Create_Task): If flag Build_Entry_Names is set,
	dynamically allocate an array
	of string pointers. This structure holds string entry names.
	(Free_Entry_Names): New routine.
	(Free_Task, Vulnerable_Free_Task): Deallocate the entry names array.
	(Set_Entry_Names): New routine.

	* s-tassta.ads:
	(Create_Task): Add formal Build_Entry_Names. The flag is used to
	control the allocation of the data structure which stores entry names.
	(Set_Entry_Name): New routine.

	* s-tpoben.adb:
	Add with and use clause for Ada.Unchecked_Conversion.
	(Finalize): Deallocate the entry names array.
	(Free_Entry_Names): New routine.
	(Initialize_Protection_Entries): When flag Build_Entry_Names is set,
	create an array of string pointers to hold the entry names.
	(Set_Entry_Name): New routine.

	* s-tpoben.ads:
	Add field Entry_Names to record Protection_Entries.
	(Initialize_Protection_Entries): Add formal Build_Entry_Names.
	(Set_Entry_Name): New routine.

From-SVN: r135896

gcc/ada/exp_ch3.adb

@@ -2477,16 +2477,15 @@ package body Exp_Ch3 is
       function Build_Init_Statements (Comp_List : Node_Id) return List_Id is
          Check_List     : constant List_Id := New_List;
          Alt_List       : List_Id;
+         Decl           : Node_Id;
+         Id             : Entity_Id;
+         Names          : Node_Id;
          Statement_List : List_Id;
          Stmts          : List_Id;
-
-         Per_Object_Constraint_Components : Boolean;
-
-         Decl     : Node_Id;
+         Typ            : Entity_Id;
          Variant        : Node_Id;
 
-         Id  : Entity_Id;
-         Typ : Entity_Id;
+         Per_Object_Constraint_Components : Boolean;
 
          function Has_Access_Constraint (E : Entity_Id) return Boolean;
          --  Components with access discriminants that depend on the current
@@ -2711,6 +2710,17 @@ package body Exp_Ch3 is
 
             Append_To (Statement_List, Make_Task_Create_Call (Rec_Type));
 
+            --  Generate the statements which map a string entry name to a
+            --  task entry index. Note that the task may not have entries.
+
+            if Entry_Names_OK then
+               Names := Build_Entry_Names (Rec_Type);
+
+               if Present (Names) then
+                  Append_To (Statement_List, Names);
+               end if;
+            end if;
+
             declare
                Task_Type : constant Entity_Id :=
                              Corresponding_Concurrent_Type (Rec_Type);
@@ -2761,6 +2771,18 @@ package body Exp_Ch3 is
          if Is_Protected_Record_Type (Rec_Type) then
             Append_List_To (Statement_List,
               Make_Initialize_Protection (Rec_Type));
+
+            --  Generate the statements which map a string entry name to a
+            --  protected entry index. Note that the protected type may not
+            --  have entries.
+
+            if Entry_Names_OK then
+               Names := Build_Entry_Names (Rec_Type);
+
+               if Present (Names) then
+                  Append_To (Statement_List, Names);
+               end if;
+            end if;
          end if;
 
          --  If no initializations when generated for component declarations
@@ -4494,15 +4516,16 @@ package body Exp_Ch3 is
                end;
             end if;
 
-            --  If the type is controlled and not limited then the target is
-            --  adjusted after the copy and attached to the finalization list.
-            --  However, no adjustment is done in the case where the object was
-            --  initialized by a call to a function whose result is built in
-            --  place, since no copy occurred. (We eventually plan to support
-            --  in-place function results for some nonlimited types. ???)
+            --  If the type is controlled and not inherently limited, then
+            --  the target is adjusted after the copy and attached to the
+            --  finalization list. However, no adjustment is done in the case
+            --  where the object was initialized by a call to a function whose
+            --  result is built in place, since no copy occurred. (Eventually
+            --  we plan to support in-place function results for some cases
+            --  of nonlimited types. ???)
 
             if Controlled_Type (Typ)
-              and then not Is_Limited_Type (Typ)
+              and then not Is_Inherently_Limited_Type (Typ)
               and then not BIP_Call
             then
                Insert_Actions_After (Init_After,

gcc/ada/exp_ch9.adb

@@ -56,6 +56,7 @@ with Sem_Util; use Sem_Util;
 with Sinfo;    use Sinfo;
 with Snames;   use Snames;
 with Stand;    use Stand;
+with Stringt;  use Stringt;
 with Targparm; use Targparm;
 with Tbuild;   use Tbuild;
 with Uintp;    use Uintp;
@@ -1106,6 +1107,334 @@ package body Exp_Ch9 is
       return Ecount;
    end Build_Entry_Count_Expression;
 
+   -----------------------
+   -- Build_Entry_Names --
+   -----------------------
+
+   function Build_Entry_Names (Conc_Typ : Entity_Id) return Node_Id is
+      Loc       : constant Source_Ptr := Sloc (Conc_Typ);
+      B_Decls   : List_Id;
+      B_Stmts   : List_Id;
+      Comp      : Node_Id;
+      Index     : Entity_Id;
+      Index_Typ : RE_Id;
+      Typ       : Entity_Id := Conc_Typ;
+
+      procedure Build_Entry_Family_Name (Id : Entity_Id);
+      --  Generate:
+      --    for Lnn in Family_Low .. Family_High loop
+      --       Inn := Inn + 1;
+      --       Set_Entry_Name
+      --         (_init._object, Inn, new String ("<Entry name> " & Lnn'Img));
+      --          _init._task_id
+      --    end loop;
+      --  Note that the bounds of the range may reference discriminants. The
+      --  above construct is added directly to the statements of the block.
+
+      procedure Build_Entry_Name (Id : Entity_Id);
+      --  Generate:
+      --    Inn := Inn + 1;
+      --    Set_Entry_Name (_init._task_id, Inn, new String ("<Entry name>");
+      --                    _init._object
+      --  The above construct is added directly to the statements of the block.
+
+      function Build_Set_Entry_Name_Call (Arg3 : Node_Id) return Node_Id;
+      --  Generate the call to the runtime routine Set_Entry_Name with actuals
+      --  _init._task_id or _init._object, Inn and Arg3.
+
+      function Find_Protection_Type (Conc_Typ : Entity_Id) return Entity_Id;
+      --  Given a protected type or its corresponding record, find the type of
+      --  field _object.
+
+      procedure Increment_Index (Stmts : List_Id);
+      --  Generate the following and add it to Stmts
+      --    Inn := Inn + 1;
+
+      -----------------------------
+      -- Build_Entry_Family_Name --
+      -----------------------------
+
+      procedure Build_Entry_Family_Name (Id : Entity_Id) is
+         Def     : constant Node_Id :=
+                     Discrete_Subtype_Definition (Parent (Id));
+         L_Id    : constant Entity_Id :=
+                     Make_Defining_Identifier (Loc, New_Internal_Name ('L'));
+         L_Stmts : constant List_Id := New_List;
+         Val     : Node_Id;
+
+         function Build_Range (Def : Node_Id) return Node_Id;
+         --  Given a discrete subtype definition of an entry family, generate a
+         --  range node which covers the range of Def's type.
+
+         -----------------
+         -- Build_Range --
+         -----------------
+
+         function Build_Range (Def : Node_Id) return Node_Id is
+            High : Node_Id := Type_High_Bound (Etype (Def));
+            Low  : Node_Id := Type_Low_Bound  (Etype (Def));
+
+         begin
+            --  If a bound references a discriminant, generate an identifier
+            --  with the same name. Resolution will map it to the formals of
+            --  the init proc.
+
+            if Is_Entity_Name (Low)
+              and then Ekind (Entity (Low)) = E_Discriminant
+            then
+               Low := Make_Identifier (Loc, Chars (Low));
+            else
+               Low := New_Copy_Tree (Low);
+            end if;
+
+            if Is_Entity_Name (High)
+              and then Ekind (Entity (High)) = E_Discriminant
+            then
+               High := Make_Identifier (Loc, Chars (High));
+            else
+               High := New_Copy_Tree (High);
+            end if;
+
+            return
+              Make_Range (Loc,
+                Low_Bound  => Low,
+                High_Bound => High);
+         end Build_Range;
+
+      --  Start of processing for Build_Entry_Family_Name
+
+      begin
+         Get_Name_String (Chars (Id));
+
+         if Is_Enumeration_Type (Etype (Def)) then
+            Name_Len := Name_Len + 1;
+            Name_Buffer (Name_Len) := ' ';
+         end if;
+
+         --  Generate:
+         --    new String'("<Entry name>" & Lnn'Img);
+
+         Val :=
+           Make_Allocator (Loc,
+             Make_Qualified_Expression (Loc,
+               Subtype_Mark =>
+                 New_Reference_To (Standard_String, Loc),
+               Expression =>
+                 Make_Op_Concat (Loc,
+                   Left_Opnd =>
+                     Make_String_Literal (Loc,
+                       String_From_Name_Buffer),
+                   Right_Opnd =>
+                     Make_Attribute_Reference (Loc,
+                       Prefix =>
+                         New_Reference_To (L_Id, Loc),
+                           Attribute_Name => Name_Img))));
+
+         Increment_Index (L_Stmts);
+         Append_To (L_Stmts, Build_Set_Entry_Name_Call (Val));
+
+         --  Generate:
+         --    for Lnn in Family_Low .. Family_High loop
+         --       Inn := Inn + 1;
+         --       Set_Entry_Name (_init._task_id, Inn, <Val>);
+         --    end loop;
+
+         Append_To (B_Stmts,
+           Make_Loop_Statement (Loc,
+             Iteration_Scheme =>
+               Make_Iteration_Scheme (Loc,
+                 Loop_Parameter_Specification =>
+                   Make_Loop_Parameter_Specification (Loc,
+                    Defining_Identifier => L_Id,
+                    Discrete_Subtype_Definition =>
+                      Build_Range (Def))),
+             Statements => L_Stmts,
+             End_Label => Empty));
+      end Build_Entry_Family_Name;
+
+      ----------------------
+      -- Build_Entry_Name --
+      ----------------------
+
+      procedure Build_Entry_Name (Id : Entity_Id) is
+         Val : Node_Id;
+
+      begin
+         Get_Name_String (Chars (Id));
+         Val :=
+           Make_Allocator (Loc,
+             Make_Qualified_Expression (Loc,
+               Subtype_Mark =>
+                 New_Reference_To (Standard_String, Loc),
+               Expression =>
+                 Make_String_Literal (Loc,
+                   String_From_Name_Buffer)));
+
+         Increment_Index (B_Stmts);
+         Append_To (B_Stmts, Build_Set_Entry_Name_Call (Val));
+      end Build_Entry_Name;
+
+      -------------------------------
+      -- Build_Set_Entry_Name_Call --
+      -------------------------------
+
+      function Build_Set_Entry_Name_Call (Arg3 : Node_Id) return Node_Id is
+         Arg1 : Name_Id;
+         Proc : RE_Id;
+
+      begin
+         --  Determine the proper name for the first argument and the RTS
+         --  routine to call.
+
+         if Is_Protected_Type (Typ) then
+            Arg1 := Name_uObject;
+            Proc := RO_PE_Set_Entry_Name;
+
+         else pragma Assert (Is_Task_Type (Typ));
+            Arg1 := Name_uTask_Id;
+            Proc := RO_TS_Set_Entry_Name;
+         end if;
+
+         --  Generate:
+         --    Set_Entry_Name (_init.Arg1, Inn, Arg3);
+
+         return
+           Make_Procedure_Call_Statement (Loc,
+             Name =>
+               New_Reference_To (RTE (Proc), Loc),
+             Parameter_Associations => New_List (
+               Make_Selected_Component (Loc,              --  _init._object
+                 Prefix =>                                --  _init._task_id
+                   Make_Identifier (Loc, Name_uInit),
+                 Selector_Name =>
+                   Make_Identifier (Loc, Arg1)),
+               New_Reference_To (Index, Loc),             --  Inn
+               Arg3));                                    --  Val
+      end Build_Set_Entry_Name_Call;
+
+      --------------------------
+      -- Find_Protection_Type --
+      --------------------------
+
+      function Find_Protection_Type (Conc_Typ : Entity_Id) return Entity_Id is
+         Comp : Entity_Id;
+         Typ  : Entity_Id := Conc_Typ;
+
+      begin
+         if Is_Concurrent_Type (Typ) then
+            Typ := Corresponding_Record_Type (Typ);
+         end if;
+
+         Comp := First_Component (Typ);
+         while Present (Comp) loop
+            if Chars (Comp) = Name_uObject then
+               return Base_Type (Etype (Comp));
+            end if;
+
+            Next_Component (Comp);
+         end loop;
+
+         --  The corresponding record of a protected type should always have an
+         --  _object field.
+
+         raise Program_Error;
+      end Find_Protection_Type;
+
+      ---------------------
+      -- Increment_Index --
+      ---------------------
+
+      procedure Increment_Index (Stmts : List_Id) is
+      begin
+         --  Generate:
+         --    Inn := Inn + 1;
+
+         Append_To (Stmts,
+           Make_Assignment_Statement (Loc,
+             Name =>
+               New_Reference_To (Index, Loc),
+             Expression =>
+               Make_Op_Add (Loc,
+                 Left_Opnd =>
+                   New_Reference_To (Index, Loc),
+                 Right_Opnd =>
+                   Make_Integer_Literal (Loc, 1))));
+      end Increment_Index;
+
+   --  Start of processing for Build_Entry_Names
+
+   begin
+      --  Retrieve the original concurrent type
+
+      if Is_Concurrent_Record_Type (Typ) then
+         Typ := Corresponding_Concurrent_Type (Typ);
+      end if;
+
+      pragma Assert (Is_Protected_Type (Typ) or else Is_Task_Type (Typ));
+
+      --  Nothing to do if the type has no entries
+
+      if not Has_Entries (Typ) then
+         return Empty;
+      end if;
+
+      --  Avoid generating entry names for a protected type with only one entry
+
+      if Is_Protected_Type (Typ)
+        and then Find_Protection_Type (Typ) /= RTE (RE_Protection_Entries)
+      then
+         return Empty;
+      end if;
+
+      Index := Make_Defining_Identifier (Loc, New_Internal_Name ('I'));
+
+      --  Step 1: Generate the declaration of the index variable:
+      --    Inn : Protected_Entry_Index := 0;
+      --      or
+      --    Inn : Task_Entry_Index := 0;
+
+      if Is_Protected_Type (Typ) then
+         Index_Typ := RE_Protected_Entry_Index;
+      else
+         Index_Typ := RE_Task_Entry_Index;
+      end if;
+
+      B_Decls := New_List;
+      Append_To (B_Decls,
+        Make_Object_Declaration (Loc,
+          Defining_Identifier => Index,
+          Object_Definition =>
+            New_Reference_To (RTE (Index_Typ), Loc),
+          Expression =>
+            Make_Integer_Literal (Loc, 0)));
+
+      B_Stmts := New_List;
+
+      --  Step 2: Generate a call to Set_Entry_Name for each entry and entry
+      --  family member.
+
+      Comp := First_Entity (Typ);
+      while Present (Comp) loop
+         if Ekind (Comp) = E_Entry then
+            Build_Entry_Name (Comp);
+
+         elsif Ekind (Comp) = E_Entry_Family then
+            Build_Entry_Family_Name (Comp);
+         end if;
+
+         Next_Entity (Comp);
+      end loop;
+
+      --  Step 3: Wrap the statements in a block
+
+      return
+        Make_Block_Statement (Loc,
+          Declarations => B_Decls,
+          Handled_Statement_Sequence =>
+            Make_Handled_Sequence_Of_Statements (Loc,
+              Statements => B_Stmts));
+   end Build_Entry_Names;
+
    ---------------------------
    -- Build_Parameter_Block --
    ---------------------------
@@ -11250,8 +11579,8 @@ package body Exp_Ch9 is
         or else Has_Abstract_Interfaces (Protect_Rec)
       then
          declare
-            Pkg_Id : constant RTU_Id := Corresponding_Runtime_Package (Ptyp);
-
+            Pkg_Id      : constant RTU_Id  :=
+                            Corresponding_Runtime_Package (Ptyp);
             Called_Subp : RE_Id;
 
          begin
@@ -11302,6 +11631,20 @@ package body Exp_Ch9 is
                       Prefix =>
                         New_Reference_To (P_Arr, Loc),
                       Attribute_Name => Name_Unrestricted_Access));
+
+                  --  Build_Entry_Names generation flag. When set to true, the
+                  --  runtime will allocate an array to hold the string names
+                  --  of protected entries.
+
+                  if not Restricted_Profile then
+                     if Entry_Names_OK then
+                        Append_To (Args,
+                          New_Reference_To (Standard_True, Loc));
+                     else
+                        Append_To (Args,
+                          New_Reference_To (Standard_False, Loc));
+                     end if;
+                  end if;
                end if;
 
             elsif Pkg_Id = System_Tasking_Protected_Objects_Single_Entry then
@@ -11310,6 +11653,7 @@ package body Exp_Ch9 is
             elsif Pkg_Id = System_Tasking_Protected_Objects_Entries then
                Append_To (Args, Make_Null (Loc));
                Append_To (Args, Make_Null (Loc));
+               Append_To (Args, New_Reference_To (Standard_False, Loc));
             end if;
 
             Append_To (L,
@@ -11422,13 +11766,13 @@ package body Exp_Ch9 is
 
    function Make_Task_Create_Call (Task_Rec : Entity_Id) return Node_Id is
       Loc    : constant Source_Ptr := Sloc (Task_Rec);
+      Args   : List_Id;
+      Ecount : Node_Id;
       Name   : Node_Id;
-      Tdef   : Node_Id;
       Tdec   : Node_Id;
-      Ttyp   : Node_Id;
+      Tdef   : Node_Id;
       Tnam   : Name_Id;
-      Args   : List_Id;
-      Ecount : Node_Id;
+      Ttyp   : Node_Id;
 
    begin
       Ttyp := Corresponding_Concurrent_Type (Task_Rec);
@@ -11682,14 +12026,29 @@ package body Exp_Ch9 is
           Prefix => Make_Identifier (Loc, Name_uInit),
           Selector_Name => Make_Identifier (Loc, Name_uTask_Id)));
 
+      --  Build_Entry_Names generation flag. When set to true, the runtime
+      --  will allocate an array to hold the string names of task entries.
+
+      if not Restricted_Profile then
+         if Has_Entries (Ttyp)
+           and then Entry_Names_OK
+         then
+            Append_To (Args, New_Reference_To (Standard_True, Loc));
+         else
+            Append_To (Args, New_Reference_To (Standard_False, Loc));
+         end if;
+      end if;
+
       if Restricted_Profile then
          Name := New_Reference_To (RTE (RE_Create_Restricted_Task), Loc);
       else
          Name := New_Reference_To (RTE (RE_Create_Task), Loc);
       end if;
 
-      return Make_Procedure_Call_Statement (Loc,
-        Name => Name, Parameter_Associations => Args);
+      return
+        Make_Procedure_Call_Statement (Loc,
+          Name => Name,
+          Parameter_Associations => Args);
    end Make_Task_Create_Call;
 
    ------------------------------

gcc/ada/exp_ch9.ads

@@ -58,6 +58,11 @@ package Exp_Ch9 is
    --  build record declaration. N is the type declaration, Ctyp is the
    --  concurrent entity (task type or protected type).
 
+   function Build_Entry_Names (Conc_Typ : Entity_Id) return Node_Id;
+   --  Create the statements which populate the entry names array of a task or
+   --  protected type. The statements are wrapped inside a block due to a local
+   --  declaration.
+
    procedure Build_Master_Entity (E : Entity_Id);
    --  Given an entity E for the declaration of an object containing tasks
    --  or of a type declaration for an allocator whose designated type is a

gcc/ada/exp_util.adb

@@ -1116,6 +1116,19 @@ package body Exp_Util is
       end if;
    end Ensure_Defined;
 
+   --------------------
+   -- Entry_Names_OK --
+   --------------------
+
+   function Entry_Names_OK return Boolean is
+   begin
+      return
+        not Restricted_Profile
+          and then not Global_Discard_Names
+          and then not Restriction_Active (No_Implicit_Heap_Allocations)
+          and then not Restriction_Active (No_Local_Allocators);
+   end Entry_Names_OK;
+
    ---------------------
    -- Evolve_And_Then --
    ---------------------

gcc/ada/exp_util.ads

@@ -314,6 +314,11 @@ package Exp_Util is
    --  used to ensure that an Itype is properly defined outside a conditional
    --  construct when it is referenced in more than one branch.
 
+   function Entry_Names_OK return Boolean;
+   --  Determine whether it is appropriate to dynamically allocate strings
+   --  which represent entry [family member] names. These strings are created
+   --  by the compiler and used by GDB.
+
    procedure Evolve_And_Then (Cond : in out Node_Id; Cond1 : Node_Id);
    --  Rewrites Cond with the expression: Cond and then Cond1. If Cond is
    --  Empty, then simply returns Cond1 (this allows the use of Empty to

gcc/ada/rtsfind.ads

@@ -1516,7 +1516,9 @@ package Rtsfind is
      RE_Lock_Entries,                    -- Tasking.Protected_Objects.Entries
      RO_PE_Get_Ceiling,                  -- Tasking.Protected_Objects.Entries
      RO_PE_Set_Ceiling,                  -- Tasking.Protected_Objects.Entries
+     RO_PE_Set_Entry_Name,               -- Tasking.Protected_Objects.Entries
      RE_Unlock_Entries,                  -- Tasking.Protected_Objects.Entries
+
      RE_Communication_Block,             -- Protected_Objects.Operations
      RE_Protected_Entry_Call,            -- Protected_Objects.Operations
      RE_Service_Entries,                 -- Protected_Objects.Operations
@@ -1590,6 +1592,7 @@ package Rtsfind is
      RE_Free_Task,                       -- System.Tasking.Stages
      RE_Expunge_Unactivated_Tasks,       -- System.Tasking.Stages
      RE_Move_Activation_Chain,           -- System_Tasking_Stages
+     RO_TS_Set_Entry_Name,               -- System.Tasking.Stages
      RE_Terminated);                     -- System.Tasking.Stages
 
    --  The following declarations build a table that is indexed by the
@@ -2652,8 +2655,11 @@ package Rtsfind is
        System_Tasking_Protected_Objects_Entries,
      RO_PE_Set_Ceiling                   =>
        System_Tasking_Protected_Objects_Entries,
+     RO_PE_Set_Entry_Name                =>
+       System_Tasking_Protected_Objects_Entries,
      RE_Unlock_Entries                   =>
        System_Tasking_Protected_Objects_Entries,
+
      RE_Communication_Block              =>
        System_Tasking_Protected_Objects_Operations,
      RE_Protected_Entry_Call             =>
@@ -2754,6 +2760,7 @@ package Rtsfind is
      RE_Free_Task                        => System_Tasking_Stages,
      RE_Expunge_Unactivated_Tasks        => System_Tasking_Stages,
      RE_Move_Activation_Chain            => System_Tasking_Stages,
+     RO_TS_Set_Entry_Name                => System_Tasking_Stages,
      RE_Terminated                       => System_Tasking_Stages);
 
    --------------------------------

gcc/ada/s-taskin.adb

@@ -35,6 +35,8 @@ pragma Polling (Off);
 --  Turn off polling, we do not want ATC polling to take place during tasking
 --  operations. It causes infinite loops and other problems.
 
+with Ada.Unchecked_Deallocation;
+
 with System.Task_Primitives.Operations;
 with System.Storage_Elements;
 
@@ -42,6 +44,19 @@ package body System.Tasking is
 
    package STPO renames System.Task_Primitives.Operations;
 
+   ----------------------------
+   -- Free_Entry_Names_Array --
+   ----------------------------
+
+   procedure Free_Entry_Names_Array (Obj : in out Entry_Names_Array) is
+      procedure Free_String is new
+        Ada.Unchecked_Deallocation (String, String_Access);
+   begin
+      for Index in Obj'Range loop
+         Free_String (Obj (Index));
+      end loop;
+   end Free_Entry_Names_Array;
+
    ---------------------
    -- Detect_Blocking --
    ---------------------

gcc/ada/s-taskin.ads

@@ -237,6 +237,19 @@ package System.Tasking is
    type Task_Entry_Queue_Array is
      array (Task_Entry_Index range <>) of Entry_Queue;
 
+   --  A data structure which contains the string names of entries and entry
+   --  family members.
+
+   type String_Access is access all String;
+
+   type Entry_Names_Array is
+     array (Entry_Index range <>) of String_Access;
+
+   type Entry_Names_Array_Access is access all Entry_Names_Array;
+
+   procedure Free_Entry_Names_Array (Obj : in out Entry_Names_Array);
+   --  Deallocate all string names contained in an entry names array
+
    ----------------------------------
    -- Entry_Call_Record definition --
    ----------------------------------
@@ -441,19 +454,17 @@ package System.Tasking is
       --  and rendezvous.
       --
       --  Ada 95 notes: In Ada 95, this field will be transferred to the
-      --  Priority field of an Entry_Calls component when an entry call
-      --  is initiated. The Priority of the Entry_Calls component will not
-      --  change for the duration of the call. The accepting task can
-      --  use it to boost its own priority without fear of its changing in
-      --  the meantime.
+      --  Priority field of an Entry_Calls component when an entry call is
+      --  initiated. The Priority of the Entry_Calls component will not change
+      --  for the duration of the call. The accepting task can use it to boost
+      --  its own priority without fear of its changing in the meantime.
       --
-      --  This can safely be used in the priority ordering
-      --  of entry queues. Once a call is queued, its priority does not
-      --  change.
+      --  This can safely be used in the priority ordering of entry queues.
+      --  Once a call is queued, its priority does not change.
       --
-      --  Since an entry call cannot be made while executing
-      --  a protected action, the priority of a task will never reflect a
-      --  priority ceiling change at the point of an entry call.
+      --  Since an entry call cannot be made while executing a protected
+      --  action, the priority of a task will never reflect a priority ceiling
+      --  change at the point of an entry call.
       --
       --  Protection: Only written by Self, and only accessed when Acceptor
       --  accepts an entry or when Created activates, at which points Self is
@@ -467,8 +478,8 @@ package System.Tasking is
       --  can be read/written from protected interrupt handlers.
 
       Task_Image : String (1 .. System.Parameters.Max_Task_Image_Length);
-      --  Hold a string that provides a readable id for task,
-      --  built from the variable of which it is a value or component.
+      --  Hold a string that provides a readable id for task, built from the
+      --  variable of which it is a value or component.
 
       Task_Image_Len : Natural;
       --  Actual length of Task_Image
@@ -489,7 +500,7 @@ package System.Tasking is
 
       Task_Arg : System.Address;
       --  The argument to task procedure. Provide a handle for discriminant
-      --  information
+      --  information.
       --
       --  Protection: Part of the synchronization between Self and Activator.
       --  Activator writes it, once, before Self starts executing. Thereafter,
@@ -605,10 +616,9 @@ package System.Tasking is
    -- Restricted_Ada_Task_Control_Block --
    ---------------------------------------
 
-   --  This type should only be used by the restricted GNARLI and by
-   --  restricted GNULL implementations to allocate an ATCB (see
-   --  System.Task_Primitives.Operations.New_ATCB) that will take
-   --  significantly less memory.
+   --  This type should only be used by the restricted GNARLI and by restricted
+   --  GNULL implementations to allocate an ATCB (see System.Task_Primitives.
+   --  Operations.New_ATCB) that will take significantly less memory.
 
    --  Note that the restricted GNARLI should only access fields that are
    --  present in the Restricted_Ada_Task_Control_Block structure.
@@ -855,6 +865,11 @@ package System.Tasking is
       --  associated with protected objects or task entries, and are protected
       --  by the protected object lock or Acceptor.L, respectively.
 
+      Entry_Names : Entry_Names_Array_Access := null;
+      --  An array of string names which denotes entry [family member] names.
+      --  The structure is indexed by task entry index and contains Entry_Num
+      --  components.
+
       New_Base_Priority : System.Any_Priority;
       --  New value for Base_Priority (for dynamic priorities package)
       --

gcc/ada/s-tassta.adb

@@ -88,6 +88,9 @@ package body System.Tasking.Stages is
    procedure Free is new
      Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
 
+   procedure Free_Entry_Names (T : Task_Id);
+   --  Deallocate all string names associated with task entries
+
    procedure Trace_Unhandled_Exception_In_Task (Self_Id : Task_Id);
    --  This procedure outputs the task specific message for exception
    --  tracing purposes.
@@ -465,7 +468,8 @@ package body System.Tasking.Stages is
       Elaborated        : Access_Boolean;
       Chain             : in out Activation_Chain;
       Task_Image        : String;
-      Created_Task      : out Task_Id)
+      Created_Task      : out Task_Id;
+      Build_Entry_Names : Boolean)
    is
       T, P          : Task_Id;
       Self_ID       : constant Task_Id := STPO.Self;
@@ -605,6 +609,11 @@ package body System.Tasking.Stages is
          T.Common.Task_Image_Len := Len;
       end if;
 
+      if Build_Entry_Names then
+         T.Entry_Names :=
+           new Entry_Names_Array (1 .. Entry_Index (Num_Entries));
+      end if;
+
       Unlock (Self_ID);
       Unlock_RTS;
 
@@ -816,6 +825,26 @@ package body System.Tasking.Stages is
 
    end Finalize_Global_Tasks;
 
+   ----------------------
+   -- Free_Entry_Names --
+   ----------------------
+
+   procedure Free_Entry_Names (T : Task_Id) is
+      Names : Entry_Names_Array_Access := T.Entry_Names;
+
+      procedure Free_Entry_Names_Array_Access is new
+        Ada.Unchecked_Deallocation
+          (Entry_Names_Array, Entry_Names_Array_Access);
+
+   begin
+      if Names = null then
+         return;
+      end if;
+
+      Free_Entry_Names_Array (Names.all);
+      Free_Entry_Names_Array_Access (Names);
+   end Free_Entry_Names;
+
    ---------------
    -- Free_Task --
    ---------------
@@ -837,6 +866,7 @@ package body System.Tasking.Stages is
 
          Initialization.Task_Unlock (Self_Id);
 
+         Free_Entry_Names (T);
          System.Task_Primitives.Operations.Finalize_TCB (T);
 
       --  If the task is not terminated, then we simply ignore the call. This
@@ -895,6 +925,23 @@ package body System.Tasking.Stages is
       Initialization.Undefer_Abort (Self_ID);
    end Move_Activation_Chain;
 
+   --  Compiler interface only. Do not call from within the RTS.
+
+   --------------------
+   -- Set_Entry_Name --
+   --------------------
+
+   procedure Set_Entry_Name
+     (T   : Task_Id;
+      Pos : Task_Entry_Index;
+      Val : String_Access)
+   is
+   begin
+      pragma Assert (T.Entry_Names /= null);
+
+      T.Entry_Names (Entry_Index (Pos)) := Val;
+   end Set_Entry_Name;
+
    ------------------
    -- Task_Wrapper --
    ------------------
@@ -1425,9 +1472,9 @@ package body System.Tasking.Stages is
       T  : aliased Task_Id;
 
       To_Be_Freed : Task_Id;
-      --  This is a list of ATCBs to be freed, after we have released
-      --  all RTS locks. This is necessary because of the locking order
-      --  rules, since the storage manager uses Global_Task_Lock.
+      --  This is a list of ATCBs to be freed, after we have released all RTS
+      --  locks. This is necessary because of the locking order rules, since
+      --  the storage manager uses Global_Task_Lock.
 
       pragma Warnings (Off);
       function Check_Unactivated_Tasks return Boolean;
@@ -1877,6 +1924,7 @@ package body System.Tasking.Stages is
          Unlock_RTS;
       end if;
 
+      Free_Entry_Names (T);
       System.Task_Primitives.Operations.Finalize_TCB (T);
    end Vulnerable_Free_Task;
 

gcc/ada/s-tassta.ads

@@ -180,7 +180,8 @@ package System.Tasking.Stages is
       Elaborated        : Access_Boolean;
       Chain             : in out Activation_Chain;
       Task_Image        : String;
-      Created_Task      : out Task_Id);
+      Created_Task      : out Task_Id;
+      Build_Entry_Names : Boolean);
    --  Compiler interface only. Do not call from within the RTS.
    --  This must be called to create a new task.
    --
@@ -205,6 +206,8 @@ package System.Tasking.Stages is
    --   run time can store to ease the debugging and the
    --   Ada.Task_Identification facility.
    --  Created_Task is the resulting task.
+   --  Build_Entry_Names is a flag which controls the allocation of the data
+   --   structure which stores all entry names.
    --
    --  This procedure can raise Storage_Error if the task creation failed.
 
@@ -276,6 +279,13 @@ package System.Tasking.Stages is
    --  that doesn't happen, they will never be activated, and will become
    --  terminated on leaving the return statement.
 
+   procedure Set_Entry_Name
+     (T   : Task_Id;
+      Pos : Task_Entry_Index;
+      Val : String_Access);
+   --  This is called by the compiler to map a string which denotes an entry
+   --  name to a task entry index.
+
    function Terminated (T : Task_Id) return Boolean;
    --  This is called by the compiler to implement the 'Terminated attribute.
    --  Though is not required to be so by the ARM, we choose to synchronize

gcc/ada/s-tpoben.adb

@@ -43,6 +43,8 @@
 
 --  Note: the compiler generates direct calls to this interface, via Rtsfind
 
+with Ada.Unchecked_Deallocation;
+
 with System.Task_Primitives.Operations;
 with System.Restrictions;
 with System.Parameters;
@@ -58,6 +60,13 @@ package body System.Tasking.Protected_Objects.Entries is
    use Parameters;
    use Task_Primitives.Operations;
 
+   -----------------------
+   -- Local Subprograms --
+   -----------------------
+
+   procedure Free_Entry_Names (Object : Protection_Entries);
+   --  Deallocate all string names associated with protected entries
+
    ----------------
    -- Local Data --
    ----------------
@@ -134,6 +143,8 @@ package body System.Tasking.Protected_Objects.Entries is
          end loop;
       end loop;
 
+      Free_Entry_Names (Object);
+
       Object.Finalized := True;
 
       if Single_Lock then
@@ -145,6 +156,26 @@ package body System.Tasking.Protected_Objects.Entries is
       STPO.Finalize_Lock (Object.L'Unrestricted_Access);
    end Finalize;
 
+   ----------------------
+   -- Free_Entry_Names --
+   ----------------------
+
+   procedure Free_Entry_Names (Object : Protection_Entries) is
+      Names : Entry_Names_Array_Access := Object.Entry_Names;
+
+      procedure Free_Entry_Names_Array_Access is new
+        Ada.Unchecked_Deallocation
+          (Entry_Names_Array, Entry_Names_Array_Access);
+
+   begin
+      if Names = null then
+         return;
+      end if;
+
+      Free_Entry_Names_Array (Names.all);
+      Free_Entry_Names_Array_Access (Names);
+   end Free_Entry_Names;
+
    -----------------
    -- Get_Ceiling --
    -----------------
@@ -177,7 +208,8 @@ package body System.Tasking.Protected_Objects.Entries is
       Ceiling_Priority  : Integer;
       Compiler_Info     : System.Address;
       Entry_Bodies      : Protected_Entry_Body_Access;
-      Find_Body_Index   : Find_Body_Index_Access)
+      Find_Body_Index   : Find_Body_Index_Access;
+      Build_Entry_Names : Boolean)
    is
       Init_Priority : Integer := Ceiling_Priority;
       Self_ID       : constant Task_Id := STPO.Self;
@@ -213,6 +245,11 @@ package body System.Tasking.Protected_Objects.Entries is
          Object.Entry_Queues (E).Head := null;
          Object.Entry_Queues (E).Tail := null;
       end loop;
+
+      if Build_Entry_Names then
+         Object.Entry_Names :=
+           new Entry_Names_Array (1 .. Entry_Index (Object.Num_Entries));
+      end if;
    end Initialize_Protection_Entries;
 
    ------------------
@@ -358,6 +395,21 @@ package body System.Tasking.Protected_Objects.Entries is
    end Set_Ceiling;
 
    --------------------
+   -- Set_Entry_Name --
+   --------------------
+
+   procedure Set_Entry_Name
+     (Object : Protection_Entries'Class;
+      Pos    : Protected_Entry_Index;
+      Val    : String_Access)
+   is
+   begin
+      pragma Assert (Object.Entry_Names /= null);
+
+      Object.Entry_Names (Entry_Index (Pos)) := Val;
+   end Set_Entry_Name;
+
+   --------------------
    -- Unlock_Entries --
    --------------------
 

gcc/ada/s-tpoben.ads

@@ -132,11 +132,16 @@ package System.Tasking.Protected_Objects.Entries is
       --  Pointer to an array containing the executable code for all entry
       --  bodies of a protected type.
 
-      --  The following function maps the entry index in a call (which denotes
-      --  the queue to the proper entry) into the body of the entry.
-
       Find_Body_Index : Find_Body_Index_Access;
+      --  A function which maps the entry index in a call (which denotes the
+      --  queue of the proper entry) into the body of the entry.
+
       Entry_Queues : Protected_Entry_Queue_Array (1 .. Num_Entries);
+
+      Entry_Names : Entry_Names_Array_Access := null;
+      --  An array of string names which denotes entry [family member] names.
+      --  The structure is indexed by protected entry index and contains Num_
+      --  Entries components.
    end record;
 
    --  No default initial values for this type, since call records
@@ -168,7 +173,8 @@ package System.Tasking.Protected_Objects.Entries is
       Ceiling_Priority  : Integer;
       Compiler_Info     : System.Address;
       Entry_Bodies      : Protected_Entry_Body_Access;
-      Find_Body_Index  : Find_Body_Index_Access);
+      Find_Body_Index   : Find_Body_Index_Access;
+      Build_Entry_Names : Boolean);
    --  Initialize the Object parameter so that it can be used by the runtime
    --  to keep track of the runtime state of a protected object.
 
@@ -202,6 +208,13 @@ package System.Tasking.Protected_Objects.Entries is
       Prio   : System.Any_Priority);
    --  Sets the new ceiling priority of the protected object
 
+   procedure Set_Entry_Name
+     (Object : Protection_Entries'Class;
+      Pos    : Protected_Entry_Index;
+      Val    : String_Access);
+   --  This is called by the compiler to map a string which denotes an entry
+   --  name to a protected entry index.
+
    procedure Unlock_Entries (Object : Protection_Entries_Access);
    --  Relinquish ownership of the lock for the object represented by the
    --  Object parameter. If this ownership was for write access, or if it was