File : a-rttiev-bb.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-2014, 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 3, 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. --
17 -- --
18 -- --
19 -- --
20 -- --
21 -- --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
26 -- --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
29 -- --
30 ------------------------------------------------------------------------------
31
32 with Ada.Unchecked_Conversion;
33
34 with System.BB.Time;
35 with System.BB.Protection;
36
37 package body Ada.Real_Time.Timing_Events is
38
39 procedure Handler_Wrapper
40 (Event : in out System.BB.Timing_Events.Timing_Event'Class) with
41 -- This wrapper is needed to make a clean conversion between
42 -- System.BB.Timing_Events.Timing_Event_Handler and
43 -- Ada.Real_Time.Timing_Events.Timing_Event_Handler.
44
45 Pre =>
46 -- Timing_Event can only be defined from the type defined in RM D.15
47 -- Ada.Real_Time.Timing_Events.Timing_Event.
48
49 Event in Ada.Real_Time.Timing_Events.Timing_Event;
50
51 package SBTE renames System.BB.Timing_Events;
52
53 ---------------------
54 -- Handler_Wrapper --
55 ---------------------
56
57 procedure Handler_Wrapper
58 (Event : in out System.BB.Timing_Events.Timing_Event'Class)
59 is
60 RT_Event : Timing_Event renames Timing_Event (Event);
61 -- View conversion on the parameter
62
63 Handler : constant Timing_Event_Handler := RT_Event.Real_Handler;
64
65 begin
66 if Handler /= null then
67 RT_Event.Real_Handler := null;
68 Handler.all (RT_Event);
69 end if;
70 end Handler_Wrapper;
71
72 -----------------
73 -- Set_Handler --
74 -----------------
75
76 procedure Set_Handler
77 (Event : in out Timing_Event;
78 At_Time : Time;
79 Handler : Timing_Event_Handler)
80 is
81 BB_Handler : constant System.BB.Timing_Events.Timing_Event_Handler :=
82 (if Handler = null then null else Handler_Wrapper'Access);
83 -- Keep a null low-level handler if we are setting a null handler
84 -- (meaning that we the event is to be cleared as per D.15 par. 11/3).
85 -- Otherwise, pass the address of the wrapper in charge of executing
86 -- the actual handler (we need a wrapper because in addition to execute
87 -- the handler we need to set the handler to null to indicate that it
88 -- has already been executed).
89
90 begin
91 -- The access to the event must be protected and atomic
92
93 System.BB.Protection.Enter_Kernel;
94
95 Event.Real_Handler := Handler;
96
97 SBTE.Set_Handler (SBTE.Timing_Event (Event),
98 System.BB.Time.Time (At_Time),
99 BB_Handler);
100
101 System.BB.Protection.Leave_Kernel;
102 end Set_Handler;
103
104 ---------------------
105 -- Current_Handler --
106 ---------------------
107
108 function Current_Handler
109 (Event : Timing_Event) return Timing_Event_Handler
110 is
111 Res : Timing_Event_Handler;
112 begin
113 -- The access to the event must be protected and atomic
114
115 System.BB.Protection.Enter_Kernel;
116
117 Res := Event.Real_Handler;
118
119 System.BB.Protection.Leave_Kernel;
120
121 return Res;
122 end Current_Handler;
123
124 --------------------
125 -- Cancel_Handler --
126 --------------------
127
128 procedure Cancel_Handler
129 (Event : in out Timing_Event;
130 Cancelled : out Boolean)
131 is
132 begin
133 -- The access to the event must be protected and atomic
134
135 System.BB.Protection.Enter_Kernel;
136
137 SBTE.Cancel_Handler (SBTE.Timing_Event (Event), Cancelled);
138 Event.Real_Handler := null;
139
140 System.BB.Protection.Leave_Kernel;
141 end Cancel_Handler;
142
143 -------------------
144 -- Time_Of_Event --
145 -------------------
146
147 function Time_Of_Event (Event : Timing_Event) return Time is
148 Res : Time;
149 begin
150 -- The access to the event must be protected and atomic
151
152 System.BB.Protection.Enter_Kernel;
153
154 Res := Time (SBTE.Time_Of_Event (SBTE.Timing_Event (Event)));
155
156 System.BB.Protection.Leave_Kernel;
157
158 return Res;
159 end Time_Of_Event;
160
161 end Ada.Real_Time.Timing_Events;