gcc/ada/a-rttiev.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --          A D A . R E A L _ T I M E . T I M I N G _ E V E N T S           --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --           Copyright (C) 2005-2006, Free Software Foundation, Inc.        --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNAT was originally developed  by the GNAT team at  New York University. --
  30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 with System.Tasking.Utilities;
  35 --  for Make_Independent
  36
  37 with Ada.Containers.Doubly_Linked_Lists;
  38 pragma Elaborate_All (Ada.Containers.Doubly_Linked_Lists);
  39
  40 package body Ada.Real_Time.Timing_Events is
  41
  42    type Any_Timing_Event is access all Timing_Event'Class;
  43    --  We must also handle user-defined types derived from Timing_Event
  44
  45    ------------
  46    -- Events --
  47    ------------
  48
  49    package Events is
  50       new Ada.Containers.Doubly_Linked_Lists (Any_Timing_Event);
  51
  52    -----------------
  53    -- Event_Queue --
  54    -----------------
  55
  56    protected Event_Queue is
  57       pragma Priority (System.Priority'Last);
  58
  59       procedure Insert (This : Any_Timing_Event);
  60       --  Inserts This into the queue in ascending order by Timeout
  61
  62       procedure Process_Events;
  63       --  Iterates over the list of events and calls the handlers for any of
  64       --  those that have timed out. Deletes those that have timed out.
  65
  66     private
  67       All_Events : Events.List;
  68    end Event_Queue;
  69
  70    -----------
  71    -- Timer --
  72    -----------
  73
  74    task Timer is
  75       pragma Priority (System.Priority'Last);
  76    end Timer;
  77
  78    task body Timer is
  79       Period : constant Time_Span := Milliseconds (100);
  80       --  This is a "chiming" clock timer that fires periodically. The period
  81       --  selected is arbitrary and could be changed to suit the application
  82       --  requirements. Obviously a shorter period would give better resolution
  83       --  at the cost of more overhead.
  84
  85    begin
  86       System.Tasking.Utilities.Make_Independent;
  87       loop
  88          Event_Queue.Process_Events;
  89          delay until Clock + Period;
  90       end loop;
  91    end Timer;
  92
  93    ------------
  94    -- Sooner --
  95    ------------
  96
  97    function Sooner (Left, Right : Any_Timing_Event) return Boolean;
  98    --  Used by the Event_Queue insertion routine to keep the events in
  99    --  ascending order by timeout value.
 100
 101    -----------------
 102    -- Event_Queue --
 103    -----------------
 104
 105    protected body Event_Queue is
 106
 107       procedure Insert (This : Any_Timing_Event) is
 108          package By_Timeout is new Events.Generic_Sorting (Sooner);
 109          --  Used to keep the events in ascending order by timeout value
 110
 111       begin
 112          All_Events.Append (This);
 113
 114          --  A critical property of the implementation of this package is that
 115          --  all occurrences are in ascending order by Timeout. Thus the first
 116          --  event in the queue always has the "next" value for the Timer task
 117          --  to use in its delay statement.
 118
 119          By_Timeout.Sort (All_Events);
 120       end Insert;
 121
 122       procedure Process_Events is
 123          Next_Event : Any_Timing_Event;
 124       begin
 125          while not All_Events.Is_Empty loop
 126             Next_Event := All_Events.First_Element;
 127
 128             --  Clients can cancel a timeout (setting the handler to null) but
 129             --  cannot otherwise change the timeout/handler tuple until the
 130             --  call to Reset below.
 131
 132             if Next_Event.Control.Current_Timeout > Clock then
 133
 134                --  We found one that has not yet timed-out. The queue is in
 135                --  ascending order by Timeout so there is no need to continue
 136                --  processing (and indeed we must not continue since we always
 137                --  delete the first element).
 138
 139                return;
 140             end if;
 141
 142             declare
 143                Response : Timing_Event_Handler;
 144
 145             begin
 146                --  We take a local snapshot of the handler to avoid a race
 147                --  condition because we evaluate the handler value in the
 148                --  if-statement and again in the call and the client might have
 149                --  set it to null between those two evaluations.
 150
 151                Response := Next_Event.Control.Current_Handler;
 152
 153                if Response /= null then
 154
 155                   --  D.15 (13/2) says we only invoke the handler if it is
 156                   --  set when the timeout expires.
 157
 158                   Response (Timing_Event (Next_Event.all));
 159                end if;
 160
 161             exception
 162                when others =>
 163                   null;  --  per D.15 (21/2)
 164             end;
 165
 166             Next_Event.Control.Reset;
 167
 168             --  Clients can now change the timeout/handler pair for this event
 169
 170             --  And now we can delete the event from the queue. Any item we
 171             --  delete would be the first in the queue because we exit the loop
 172             --  when we first find one that is not yet timed-out. This fact
 173             --  allows us to use these "First oriented" list processing
 174             --  routines instead of the cursor oriented versions because we can
 175             --  avoid handling the way deletion affects cursors.
 176
 177             All_Events.Delete_First;
 178          end loop;
 179       end Process_Events;
 180
 181    end Event_Queue;
 182
 183    -----------------
 184    -- Set_Handler --
 185    -----------------
 186
 187    procedure Set_Handler
 188      (Event   : in out Timing_Event;
 189       At_Time : Time;
 190       Handler : Timing_Event_Handler)
 191    is
 192    begin
 193       Event.Control.Cancel;
 194
 195       if At_Time <= Clock then
 196          if Handler /= null then
 197             Handler (Event);
 198          end if;
 199          return;
 200       end if;
 201
 202       if Handler /= null then
 203          Event.Control.Set (At_Time, Handler);
 204          Event_Queue.Insert (Event'Unchecked_Access);
 205       end if;
 206    end Set_Handler;
 207
 208    -----------------
 209    -- Set_Handler --
 210    -----------------
 211
 212    procedure Set_Handler
 213      (Event   : in out Timing_Event;
 214       In_Time : Time_Span;
 215       Handler : Timing_Event_Handler)
 216    is
 217    begin
 218       Event.Control.Cancel;
 219
 220       if In_Time <= Time_Span_Zero then
 221          if Handler /= null then
 222             Handler (Event);
 223          end if;
 224          return;
 225       end if;
 226
 227       if Handler /= null then
 228          Event.Control.Set (Clock + In_Time, Handler);
 229          Event_Queue.Insert (Event'Unchecked_Access);
 230       end if;
 231    end Set_Handler;
 232
 233    -----------------
 234    -- Event_State --
 235    -----------------
 236
 237    protected body Event_State is
 238
 239       entry Set
 240         (Timeout : Time;
 241          Handler : Timing_Event_Handler)
 242       when
 243          Available
 244       is
 245       begin
 246          Event_State.Timeout := Set.Timeout;
 247          Event_State.Handler := Set.Handler;
 248          Available := False;
 249       end Set;
 250
 251       procedure Reset is
 252       begin
 253          Cancel;
 254          Available := True;
 255       end Reset;
 256
 257       procedure Cancel is
 258       begin
 259          Handler := null;
 260          Timeout := Time_First;
 261       end Cancel;
 262
 263       function Current_Timeout return Time is
 264       begin
 265          return Timeout;
 266       end Current_Timeout;
 267
 268       function Current_Handler return Timing_Event_Handler is
 269       begin
 270          return Handler;
 271       end Current_Handler;
 272
 273    end Event_State;
 274
 275    ---------------------
 276    -- Current_Handler --
 277    ---------------------
 278
 279    function Current_Handler
 280      (Event : Timing_Event) return Timing_Event_Handler
 281    is
 282    begin
 283       return Event.Control.Current_Handler;
 284    end Current_Handler;
 285
 286    --------------------
 287    -- Cancel_Handler --
 288    --------------------
 289
 290    procedure Cancel_Handler
 291      (Event     : in out Timing_Event;
 292       Cancelled : out Boolean)
 293    is
 294    begin
 295       Cancelled := Event.Control.Current_Handler /= null;
 296       Event.Control.Cancel;
 297    end Cancel_Handler;
 298
 299    -------------------
 300    -- Time_Of_Event --
 301    -------------------
 302
 303    function Time_Of_Event (Event : Timing_Event) return Time is
 304    begin
 305       return Event.Control.Current_Timeout;
 306    end Time_Of_Event;
 307
 308    ------------
 309    -- Sooner --
 310    ------------
 311
 312    function Sooner (Left, Right : Any_Timing_Event) return Boolean is
 313    begin
 314       return Left.Control.Current_Timeout < Right.Control.Current_Timeout;
 315    end Sooner;
 316
 317    --------------
 318    -- Finalize --
 319    --------------
 320
 321    procedure Finalize (This : in out Timing_Event) is
 322    begin
 323       --  D.15 (19/2) says finalization clears the event
 324
 325       This.Control.Cancel;
 326    end Finalize;
 327
 328 end Ada.Real_Time.Timing_Events;