2006-10-31 Javier Miranda <miranda@adacore.com>

* s-tpoben.ads, s-tpoben.adb, s-taprob.ads, s-taprob.adb
	(Get_Ceiling): New subprogram that returns
	the ceiling priority of the protected object.
	(Set_Ceiling): New subprogram that sets the new ceiling priority of
	the protected object.

	* s-tarest.adb: (Create_Restricted_Task): Fix potential CE.

	* s-taskin.ads, s-taskin.adb: (Storage_Size): New function.

From-SVN: r118317

gcc/ada/s-taprob.adb

@@ -7,7 +7,7 @@
 --                                  B o d y                                 --
 --                                                                          --
 --             Copyright (C) 1991-1994, Florida State University            --
---                     Copyright (C) 1995-2005, AdaCore                     --
+--                     Copyright (C) 1995-2006, AdaCore                     --
 --                                                                          --
 -- GNARL 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- --
@@ -81,9 +81,20 @@ package body System.Tasking.Protected_Objects is
 
       Initialize_Lock (Init_Priority, Object.L'Access);
       Object.Ceiling := System.Any_Priority (Init_Priority);
+      Object.New_Ceiling := System.Any_Priority (Init_Priority);
       Object.Owner := Null_Task;
    end Initialize_Protection;
 
+   -----------------
+   -- Get_Ceiling --
+   -----------------
+
+   function Get_Ceiling
+     (Object : Protection_Access) return System.Any_Priority is
+   begin
+      return Object.New_Ceiling;
+   end Get_Ceiling;
+
    ----------
    -- Lock --
    ----------
@@ -199,6 +210,17 @@ package body System.Tasking.Protected_Objects is
       end if;
    end Lock_Read_Only;
 
+   -----------------
+   -- Set_Ceiling --
+   -----------------
+
+   procedure Set_Ceiling
+     (Object : Protection_Access;
+      Prio   : System.Any_Priority) is
+   begin
+      Object.New_Ceiling := Prio;
+   end Set_Ceiling;
+
    ------------
    -- Unlock --
    ------------

gcc/ada/s-taprob.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                  S p e c                                 --
 --                                                                          --
---          Copyright (C) 1992-2005, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2006, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNARL 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- --
@@ -45,7 +45,7 @@
 
 --  Note: the compiler generates direct calls to this interface, via Rtsfind.
 --  Any changes to this interface may require corresponding compiler changes
---  in exp_ch9.adb and possibly exp_ch7.adb
+--  in exp_ch9.adb and possibly exp_ch7.adb and exp_attr.adb
 
 package System.Tasking.Protected_Objects is
    pragma Elaborate_Body;
@@ -172,6 +172,10 @@ package System.Tasking.Protected_Objects is
 
    Null_PO : constant Protection_Access := null;
 
+   function Get_Ceiling
+     (Object : Protection_Access) return System.Any_Priority;
+   --  Returns the new ceiling priority of the protected object
+
    procedure Initialize_Protection
      (Object           : Protection_Access;
       Ceiling_Priority : Integer);
@@ -196,6 +200,11 @@ package System.Tasking.Protected_Objects is
    --  for possible future use. At the current time, everyone uses Lock
    --  for both read and write locks.
 
+   procedure Set_Ceiling
+     (Object : Protection_Access;
+      Prio   : System.Any_Priority);
+   --  Sets the new ceiling priority of the protected object
+
    procedure Unlock (Object : Protection_Access);
    --  Relinquish ownership of the lock for the object represented by
    --  the Object parameter. If this ownership was for write access, or
@@ -212,6 +221,16 @@ private
       Ceiling : System.Any_Priority;
       --  Ceiling priority associated to the protected object
 
+      New_Ceiling : System.Any_Priority;
+      --  New ceiling priority associated to the protected object. In case
+      --  of assignment of a new ceiling priority to the protected object the
+      --  frontend generates a call to set_ceiling to save the new value in
+      --  this field. After such assignment this value can be read by means
+      --  of the 'Priority attribute, which generates a call to get_ceiling.
+      --  However, the ceiling of the protected object will not be changed
+      --  until completion of the protected action in which the assignment
+      --  has been executed (AARM D.5.2 (10/2)).
+
       Owner : Task_Id;
       --  This field contains the protected object's owner. Null_Task
       --  indicates that the protected object is not currently being used.

gcc/ada/s-tarest.adb

@@ -473,6 +473,7 @@ package body System.Tasking.Restricted.Stages is
       Self_ID       : constant Task_Id := STPO.Self;
       Base_Priority : System.Any_Priority;
       Success       : Boolean;
+      Len           : Integer;
 
    begin
       --  Stack is not preallocated on this target, so that Stack_Address must
@@ -515,10 +516,11 @@ package body System.Tasking.Restricted.Stages is
 
       Created_Task.Entry_Calls (1).Self := Created_Task;
 
-      Created_Task.Common.Task_Image_Len :=
+      Len :=
         Integer'Min (Created_Task.Common.Task_Image'Length, Task_Image'Length);
-      Created_Task.Common.Task_Image
+      Created_Task.Common.Task_Image_Len := Len;
-        (1 .. Created_Task.Common.Task_Image_Len) := Task_Image;
+      Created_Task.Common.Task_Image (1 .. Len) :=
+        Task_Image (Task_Image'First .. Task_Image'First + Len - 1);
 
       Unlock (Self_ID);
 

gcc/ada/s-taskin.adb

@@ -66,6 +66,17 @@ package body System.Tasking is
 
    function Self return Task_Id renames STPO.Self;
 
+   ------------------
+   -- Storage_Size --
+   ------------------
+
+   function Storage_Size (T : Task_Id) return System.Parameters.Size_Type is
+   begin
+      return
+         System.Parameters.Size_Type
+           (T.Common.Compiler_Data.Pri_Stack_Info.Size);
+   end Storage_Size;
+
    ---------------------
    -- Initialize_ATCB --
    ---------------------

gcc/ada/s-taskin.ads

@@ -377,6 +377,12 @@ package System.Tasking is
    pragma Inline (Detect_Blocking);
    --  Return whether the Detect_Blocking pragma is enabled
 
+   function Storage_Size (T : Task_Id) return System.Parameters.Size_Type;
+   --  Retrieve from the TCB of the task the allocated size of its stack,
+   --  either the system default or the size specified by a pragma. This
+   --  is in general a non-static value that can depend on discriminants
+   --  of the task.
+
    ----------------------------------------------
    -- Ada_Task_Control_Block (ATCB) definition --
    ----------------------------------------------

gcc/ada/s-tpoben.adb

@@ -7,7 +7,7 @@
 --                                                                          --
 --                                  B o d y                                 --
 --                                                                          --
---         Copyright (C) 1998-2005, Free Software Foundation, Inc.          --
+--         Copyright (C) 1998-2006, Free Software Foundation, Inc.          --
 --                                                                          --
 -- GNARL 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- --
@@ -162,6 +162,16 @@ package body System.Tasking.Protected_Objects.Entries is
       STPO.Finalize_Lock (Object.L'Unrestricted_Access);
    end Finalize;
 
+   -----------------
+   -- Get_Ceiling --
+   -----------------
+
+   function Get_Ceiling
+     (Object : Protection_Entries_Access) return System.Any_Priority is
+   begin
+      return Object.New_Ceiling;
+   end Get_Ceiling;
+
    -------------------------------------
    -- Has_Interrupt_Or_Attach_Handler --
    -------------------------------------
@@ -349,6 +359,17 @@ package body System.Tasking.Protected_Objects.Entries is
       end if;
    end Lock_Read_Only_Entries;
 
+   -----------------
+   -- Set_Ceiling --
+   -----------------
+
+   procedure Set_Ceiling
+     (Object : Protection_Entries_Access;
+      Prio   : System.Any_Priority) is
+   begin
+      Object.New_Ceiling := Prio;
+   end Set_Ceiling;
+
    --------------------
    -- Unlock_Entries --
    --------------------

gcc/ada/s-tpoben.ads

@@ -7,7 +7,7 @@
 --                                                                          --
 --                                  S p e c                                 --
 --                                                                          --
---          Copyright (C) 1992-2005, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2006, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNARL 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- --
@@ -93,6 +93,16 @@ package System.Tasking.Protected_Objects.Entries is
       Ceiling : System.Any_Priority;
       --  Ceiling priority associated with the protected object
 
+      New_Ceiling : System.Any_Priority;
+      --  New ceiling priority associated to the protected object. In case
+      --  of assignment of a new ceiling priority to the protected object the
+      --  frontend generates a call to set_ceiling to save the new value in
+      --  this field. After such assignment this value can be read by means
+      --  of the 'Priority attribute, which generates a call to get_ceiling.
+      --  However, the ceiling of the protected object will not be changed
+      --  until completion of the protected action in which the assignment
+      --  has been executed (AARM D.5.2 (10/2)).
+
       Owner : Task_Id;
       --  This field contains the protected object's owner. Null_Task
       --  indicates that the protected object is not currently being used.
@@ -142,6 +152,10 @@ package System.Tasking.Protected_Objects.Entries is
    function To_Protection is
      new Unchecked_Conversion (System.Address, Protection_Entries_Access);
 
+   function Get_Ceiling
+     (Object : Protection_Entries_Access) return System.Any_Priority;
+   --  Returns the new ceiling priority of the protected object
+
    function Has_Interrupt_Or_Attach_Handler
      (Object : Protection_Entries_Access) return Boolean;
    --  Returns True if an Interrupt_Handler or Attach_Handler pragma applies
@@ -183,6 +197,11 @@ package System.Tasking.Protected_Objects.Entries is
    --  possible future use. At the current time, everyone uses Lock for both
    --  read and write locks.
 
+   procedure Set_Ceiling
+     (Object : Protection_Entries_Access;
+      Prio   : System.Any_Priority);
+   --  Sets the new ceiling priority of the protected object
+
    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