1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
5 -- A D A . R E A L _ T I M E . T I M I N G _ E V E N T S --
9 -- Copyright (C) 2005-2006, Free Software Foundation, Inc. --
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. --
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. --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
32 ------------------------------------------------------------------------------
34 with System.Tasking.Utilities;
35 -- for Make_Independent
37 with Ada.Containers.Doubly_Linked_Lists;
38 pragma Elaborate_All (Ada.Containers.Doubly_Linked_Lists);
40 package body Ada.Real_Time.Timing_Events is
42 type Any_Timing_Event is access all Timing_Event'Class;
43 -- We must also handle user-defined types derived from Timing_Event
50 new Ada.Containers.Doubly_Linked_Lists (Any_Timing_Event);
56 protected Event_Queue is
57 pragma Priority (System.Priority'Last);
59 procedure Insert (This : Any_Timing_Event);
60 -- Inserts This into the queue in ascending order by Timeout
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.
67 All_Events : Events.List;
75 pragma Priority (System.Priority'Last);
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.
86 System.Tasking.Utilities.Make_Independent;
88 Event_Queue.Process_Events;
89 delay until Clock + Period;
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.
105 protected body Event_Queue is
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
112 All_Events.Append (This);
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.
119 By_Timeout.Sort (All_Events);
122 procedure Process_Events is
123 Next_Event : Any_Timing_Event;
125 while not All_Events.Is_Empty loop
126 Next_Event := All_Events.First_Element;
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.
132 if Next_Event.Control.Current_Timeout > Clock then
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).
143 Response : Timing_Event_Handler;
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.
151 Response := Next_Event.Control.Current_Handler;
153 if Response /= null then
155 -- D.15 (13/2) says we only invoke the handler if it is
156 -- set when the timeout expires.
158 Response (Timing_Event (Next_Event.all));
163 null; -- per D.15 (21/2)
166 Next_Event.Control.Reset;
168 -- Clients can now change the timeout/handler pair for this event
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.
177 All_Events.Delete_First;
187 procedure Set_Handler
188 (Event : in out Timing_Event;
190 Handler : Timing_Event_Handler)
193 Event.Control.Cancel;
195 if At_Time <= Clock then
196 if Handler /= null then
202 if Handler /= null then
203 Event.Control.Set (At_Time, Handler);
204 Event_Queue.Insert (Event'Unchecked_Access);
212 procedure Set_Handler
213 (Event : in out Timing_Event;
215 Handler : Timing_Event_Handler)
218 Event.Control.Cancel;
220 if In_Time <= Time_Span_Zero then
221 if Handler /= null then
227 if Handler /= null then
228 Event.Control.Set (Clock + In_Time, Handler);
229 Event_Queue.Insert (Event'Unchecked_Access);
237 protected body Event_State is
241 Handler : Timing_Event_Handler)
246 Event_State.Timeout := Set.Timeout;
247 Event_State.Handler := Set.Handler;
260 Timeout := Time_First;
263 function Current_Timeout return Time is
268 function Current_Handler return Timing_Event_Handler is
275 ---------------------
276 -- Current_Handler --
277 ---------------------
279 function Current_Handler
280 (Event : Timing_Event) return Timing_Event_Handler
283 return Event.Control.Current_Handler;
290 procedure Cancel_Handler
291 (Event : in out Timing_Event;
292 Cancelled : out Boolean)
295 Cancelled := Event.Control.Current_Handler /= null;
296 Event.Control.Cancel;
303 function Time_Of_Event (Event : Timing_Event) return Time is
305 return Event.Control.Current_Timeout;
312 function Sooner (Left, Right : Any_Timing_Event) return Boolean is
314 return Left.Control.Current_Timeout < Right.Control.Current_Timeout;
321 procedure Finalize (This : in out Timing_Event) is
323 -- D.15 (19/2) says finalization clears the event
328 end Ada.Real_Time.Timing_Events;