home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / adav313.zip / gnat-3_13p-os2-bin-20010916.zip / emx / gnatlib / s-tpoben.adb < prev    next >
Text File  |  2000-07-19  |  10KB  |  244 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS               --
  4. --                                                                          --
  5. --     S Y S T E M . T A S K I N G . P R O T E C T E D _ O B J E C T S .    --
  6. --                               E N T R I E S                              --
  7. --                                                                          --
  8. --                                  B o d y                                 --
  9. --                                                                          --
  10. --                             $Revision: 1.7 $
  11. --                                                                          --
  12. --            Copyright (C) 1991-1999, Florida State University             --
  13. --                                                                          --
  14. -- GNARL is free software; you can  redistribute it  and/or modify it under --
  15. -- terms of the  GNU General Public License as published  by the Free Soft- --
  16. -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  17. -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
  18. -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  19. -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  20. -- for  more details.  You should have  received  a copy of the GNU General --
  21. -- Public License  distributed with GNARL; see file COPYING.  If not, write --
  22. -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  23. -- MA 02111-1307, USA.                                                      --
  24. --                                                                          --
  25. -- As a special exception,  if other files  instantiate  generics from this --
  26. -- unit, or you link  this unit with other files  to produce an executable, --
  27. -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  28. -- covered  by the  GNU  General  Public  License.  This exception does not --
  29. -- however invalidate  any other reasons why  the executable file  might be --
  30. -- covered by the  GNU Public License.                                      --
  31. --                                                                          --
  32. -- GNARL was developed by the GNARL team at Florida State University. It is --
  33. -- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
  34. -- State University (http://www.gnat.com).                                  --
  35. --                                                                          --
  36. ------------------------------------------------------------------------------
  37.  
  38. --  This package contains all the simple primitives related to
  39. --  Protected_Objects with entries (i.e init, lock, unlock).
  40.  
  41. --  The handling of protected objects with no entries is done in
  42. --  System.Tasking.Protected_Objects, the complex routines for protected
  43. --  objects with entries in System.Tasking.Protected_Objects.Operations.
  44. --  The split between Entries and Operations is needed to break circular
  45. --  dependencies inside the run time.
  46.  
  47. --  Note: the compiler generates direct calls to this interface, via Rtsfind.
  48.  
  49. with Ada.Exceptions;
  50. --  used for Exception_Occurrence_Access
  51.  
  52. with System.Task_Primitives.Operations;
  53. --  used for Initialize_Lock
  54. --           Write_Lock
  55. --           Unlock
  56. --           Get_Priority
  57. --           Wakeup
  58.  
  59. with System.Tasking.Initialization;
  60. --  used for Defer_Abort,
  61. --           Undefer_Abort,
  62. --           Change_Base_Priority
  63.  
  64. pragma Elaborate_All (System.Tasking.Initialization);
  65. --  this insures that tasking is initialized if any protected objects are
  66. --  created.
  67.  
  68. package body System.Tasking.Protected_Objects.Entries is
  69.  
  70.    package STPO renames System.Task_Primitives.Operations;
  71.  
  72.    use Ada.Exceptions;
  73.    use STPO;
  74.  
  75.    Locking_Policy : Character;
  76.    pragma Import (C, Locking_Policy, "__gl_locking_policy");
  77.  
  78.    -----------------------------------
  79.    -- Initialize_Protection_Entries --
  80.    -----------------------------------
  81.  
  82.    procedure Initialize_Protection_Entries
  83.      (Object            : Protection_Entries_Access;
  84.       Ceiling_Priority  : Integer;
  85.       Compiler_Info     : System.Address;
  86.       Entry_Bodies      : Protected_Entry_Body_Access;
  87.       Find_Body_Index   : Find_Body_Index_Access)
  88.    is
  89.       Init_Priority : Integer := Ceiling_Priority;
  90.       Self_ID       : constant Task_ID := STPO.Self;
  91.  
  92.    begin
  93.       if Init_Priority = Unspecified_Priority then
  94.          Init_Priority  := System.Priority'Last;
  95.       end if;
  96.  
  97.       if Locking_Policy = 'C'
  98.         and then Has_Interrupt_Or_Attach_Handler (Object)
  99.         and then Init_Priority not in System.Interrupt_Priority
  100.       then
  101.          --  Required by C.3.1(11)
  102.  
  103.          raise Program_Error;
  104.       end if;
  105.  
  106.       Initialization.Defer_Abort (Self_ID);
  107.       Initialize_Lock (Init_Priority, Object.L'Access);
  108.       Initialization.Undefer_Abort (Self_ID);
  109.       Object.Ceiling := System.Any_Priority (Init_Priority);
  110.       Object.Compiler_Info := Compiler_Info;
  111.       Object.Pending_Action := False;
  112.       Object.Call_In_Progress := null;
  113.       Object.Entry_Bodies := Protected_Entry_Body_Access (Entry_Bodies);
  114.       Object.Find_Body_Index :=  Find_Body_Index;
  115.  
  116.       for E in Object.Entry_Queues'Range loop
  117.          Object.Entry_Queues (E).Head := null;
  118.          Object.Entry_Queues (E).Tail := null;
  119.       end loop;
  120.    end Initialize_Protection_Entries;
  121.  
  122.    ------------------
  123.    -- Lock_Entries --
  124.    ------------------
  125.  
  126.    --  Compiler interface only.
  127.    --  Do not call this procedure from within the runtime system.
  128.  
  129.    procedure Lock_Entries (Object : Protection_Entries_Access) is
  130.       Ceiling_Violation : Boolean;
  131.  
  132.    begin
  133.       --  The lock is made without defering abortion.
  134.  
  135.       --  Therefore the abortion has to be deferred before calling this
  136.       --  routine. This means that the compiler has to generate a Defer_Abort
  137.       --  call before the call to Lock.
  138.  
  139.       --  The caller is responsible for undeferring abortion, and compiler
  140.       --  generated calls must be protected with cleanup handlers to ensure
  141.       --  that abortion is undeferred in all cases.
  142.  
  143.       pragma Assert (STPO.Self.Deferral_Level > 0);
  144.  
  145.       Write_Lock (Object.L'Access, Ceiling_Violation);
  146.       if Ceiling_Violation then
  147.          Raise_Exception (Program_Error'Identity, "Ceiling Violation");
  148.       end if;
  149.    end Lock_Entries;
  150.  
  151.    ----------------------------
  152.    -- Lock_Read_Only_Entries --
  153.    ----------------------------
  154.  
  155.    --  Compiler interface only.
  156.    --  Do not call this procedure from within the runtime system.
  157.  
  158.    procedure Lock_Read_Only_Entries
  159.      (Object : Protection_Entries_Access)
  160.    is
  161.       Ceiling_Violation : Boolean;
  162.    begin
  163.       Read_Lock (Object.L'Access, Ceiling_Violation);
  164.  
  165.       if Ceiling_Violation then
  166.          Raise_Exception (Program_Error'Identity, "Ceiling Violation");
  167.       end if;
  168.    end Lock_Read_Only_Entries;
  169.  
  170.    --------------------
  171.    -- Unlock_Entries --
  172.    --------------------
  173.  
  174.    procedure Unlock_Entries (Object : Protection_Entries_Access) is
  175.    begin
  176.       Unlock (Object.L'Access);
  177.    end Unlock_Entries;
  178.  
  179.    -------------------------------------
  180.    -- Has_Interrupt_Or_Attach_Handler --
  181.    -------------------------------------
  182.  
  183.    function Has_Interrupt_Or_Attach_Handler
  184.      (Object : Protection_Entries_Access) return Boolean is
  185.    begin
  186.       return False;
  187.    end Has_Interrupt_Or_Attach_Handler;
  188.  
  189.    --------------
  190.    -- Finalize --
  191.    --------------
  192.  
  193.    procedure Finalize (Object : in out Protection_Entries) is
  194.       Entry_Call        : Entry_Call_Link;
  195.       Caller            : Task_ID;
  196.       Ceiling_Violation : Boolean;
  197.       Self_ID           : constant Task_ID := STPO.Self;
  198.       Old_Base_Priority : System.Any_Priority;
  199.  
  200.    begin
  201.       STPO.Write_Lock (Object.L'Unrestricted_Access, Ceiling_Violation);
  202.  
  203.       if Ceiling_Violation then
  204.  
  205.          --  Dip our own priority down to ceiling of lock.
  206.          --  See similar code in Tasking.Entry_Calls.Lock_Server.
  207.  
  208.          STPO.Write_Lock (Self_ID);
  209.          Old_Base_Priority := Self_ID.Common.Base_Priority;
  210.          Self_ID.New_Base_Priority := Object.Ceiling;
  211.          Initialization.Change_Base_Priority (Self_ID);
  212.          STPO.Unlock (Self_ID);
  213.          STPO.Write_Lock (Object.L'Unrestricted_Access, Ceiling_Violation);
  214.  
  215.          if Ceiling_Violation then
  216.             Raise_Exception (Program_Error'Identity, "Ceiling Violation");
  217.          end if;
  218.  
  219.          Object.Old_Base_Priority := Old_Base_Priority;
  220.          Object.Pending_Action := True;
  221.       end if;
  222.  
  223.       --  Send program_error to all tasks still queued on this object.
  224.  
  225.       for E in Object.Entry_Queues'Range loop
  226.          Entry_Call := Object.Entry_Queues (E).Head;
  227.  
  228.          while Entry_Call /= null loop
  229.             Caller := Entry_Call.Self;
  230.             Entry_Call.Exception_To_Raise := Program_Error'Identity;
  231.             STPO.Write_Lock (Caller);
  232.             Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
  233.             STPO.Unlock (Caller);
  234.             exit when Entry_Call = Object.Entry_Queues (E).Tail;
  235.             Entry_Call := Entry_Call.Next;
  236.          end loop;
  237.       end loop;
  238.  
  239.       STPO.Unlock (Object.L'Unrestricted_Access);
  240.       STPO.Finalize_Lock (Object.L'Unrestricted_Access);
  241.    end Finalize;
  242.  
  243. end System.Tasking.Protected_Objects.Entries;
  244.