aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.8.3/gcc/ada/a-rttiev.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.8.3/gcc/ada/a-rttiev.adb')
-rw-r--r--gcc-4.8.3/gcc/ada/a-rttiev.adb375
1 files changed, 375 insertions, 0 deletions
diff --git a/gcc-4.8.3/gcc/ada/a-rttiev.adb b/gcc-4.8.3/gcc/ada/a-rttiev.adb
new file mode 100644
index 000000000..67b81c72b
--- /dev/null
+++ b/gcc-4.8.3/gcc/ada/a-rttiev.adb
@@ -0,0 +1,375 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . R E A L _ T I M E . T I M I N G _ E V E N T S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2005-2011, Free Software Foundation, Inc. --
+-- --
+-- GNAT 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- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with System.Task_Primitives.Operations;
+with System.Tasking.Utilities;
+with System.Soft_Links;
+with System.Interrupt_Management.Operations;
+
+with Ada.Containers.Doubly_Linked_Lists;
+pragma Elaborate_All (Ada.Containers.Doubly_Linked_Lists);
+
+---------------------------------
+-- Ada.Real_Time.Timing_Events --
+---------------------------------
+
+package body Ada.Real_Time.Timing_Events is
+
+ use System.Task_Primitives.Operations;
+
+ package SSL renames System.Soft_Links;
+
+ type Any_Timing_Event is access all Timing_Event'Class;
+ -- We must also handle user-defined types derived from Timing_Event
+
+ ------------
+ -- Events --
+ ------------
+
+ package Events is new Ada.Containers.Doubly_Linked_Lists (Any_Timing_Event);
+ -- Provides the type for the container holding pointers to events
+
+ All_Events : Events.List;
+ -- The queue of pending events, ordered by increasing timeout value, that
+ -- have been "set" by the user via Set_Handler.
+
+ Event_Queue_Lock : aliased System.Task_Primitives.RTS_Lock;
+ -- Used for mutually exclusive access to All_Events
+
+ procedure Process_Queued_Events;
+ -- Examine the queue of pending events for any that have timed out. For
+ -- those that have timed out, remove them from the queue and invoke their
+ -- handler (unless the user has cancelled the event by setting the handler
+ -- pointer to null). Mutually exclusive access is held via Event_Queue_Lock
+ -- during part of the processing.
+
+ procedure Insert_Into_Queue (This : Any_Timing_Event);
+ -- Insert the specified event pointer into the queue of pending events
+ -- with mutually exclusive access via Event_Queue_Lock.
+
+ procedure Remove_From_Queue (This : Any_Timing_Event);
+ -- Remove the specified event pointer from the queue of pending events with
+ -- mutually exclusive access via Event_Queue_Lock. This procedure is used
+ -- by the client-side routines (Set_Handler, etc.).
+
+ -----------
+ -- Timer --
+ -----------
+
+ task Timer is
+ pragma Priority (System.Priority'Last);
+ entry Start;
+ end Timer;
+
+ task body Timer is
+ Period : constant Time_Span := Milliseconds (100);
+ -- This is a "chiming" clock timer that fires periodically. The period
+ -- selected is arbitrary and could be changed to suit the application
+ -- requirements. Obviously a shorter period would give better resolution
+ -- at the cost of more overhead.
+
+ begin
+ System.Tasking.Utilities.Make_Independent;
+
+ -- Since this package may be elaborated before System.Interrupt,
+ -- we need to call Setup_Interrupt_Mask explicitly to ensure that
+ -- this task has the proper signal mask.
+
+ System.Interrupt_Management.Operations.Setup_Interrupt_Mask;
+
+ -- We await the call to Start to ensure that Event_Queue_Lock has been
+ -- initialized by the package executable part prior to accessing it in
+ -- the loop. The task is activated before the first statement of the
+ -- executable part so it would otherwise be possible for the task to
+ -- call EnterCriticalSection in Process_Queued_Events before the
+ -- initialization.
+
+ -- We don't simply put the initialization here, prior to the loop,
+ -- because other application tasks could call the visible routines that
+ -- also call Enter/LeaveCriticalSection prior to this task doing the
+ -- initialization.
+
+ accept Start;
+
+ loop
+ Process_Queued_Events;
+ delay until Clock + Period;
+ end loop;
+ end Timer;
+
+ ---------------------------
+ -- Process_Queued_Events --
+ ---------------------------
+
+ procedure Process_Queued_Events is
+ Next_Event : Any_Timing_Event;
+
+ begin
+ loop
+ SSL.Abort_Defer.all;
+
+ Write_Lock (Event_Queue_Lock'Access);
+
+ if All_Events.Is_Empty then
+ Unlock (Event_Queue_Lock'Access);
+ SSL.Abort_Undefer.all;
+ return;
+ else
+ Next_Event := All_Events.First_Element;
+ end if;
+
+ if Next_Event.Timeout > Clock then
+
+ -- We found one that has not yet timed out. The queue is in
+ -- ascending order by Timeout so there is no need to continue
+ -- processing (and indeed we must not continue since we always
+ -- delete the first element).
+
+ Unlock (Event_Queue_Lock'Access);
+ SSL.Abort_Undefer.all;
+ return;
+ end if;
+
+ -- We have an event that has timed out so we will process it. It must
+ -- be the first in the queue so no search is needed.
+
+ All_Events.Delete_First;
+
+ -- A fundamental issue is that the invocation of the event's handler
+ -- might call Set_Handler on itself to re-insert itself back into the
+ -- queue of future events. Thus we cannot hold the lock on the queue
+ -- while invoking the event's handler.
+
+ Unlock (Event_Queue_Lock'Access);
+
+ SSL.Abort_Undefer.all;
+
+ -- There is no race condition with the user changing the handler
+ -- pointer while we are processing because we are executing at the
+ -- highest possible application task priority and are not doing
+ -- anything to block prior to invoking their handler.
+
+ declare
+ Handler : constant Timing_Event_Handler := Next_Event.Handler;
+
+ begin
+ -- The first act is to clear the event, per D.15(13/2). Besides,
+ -- we cannot clear the handler pointer *after* invoking the
+ -- handler because the handler may have re-inserted the event via
+ -- Set_Event. Thus we take a copy and then clear the component.
+
+ Next_Event.Handler := null;
+
+ if Handler /= null then
+ Handler.all (Timing_Event (Next_Event.all));
+ end if;
+
+ -- Ignore exceptions propagated by Handler.all, as required by
+ -- RM D.15(21/2).
+
+ exception
+ when others =>
+ null;
+ end;
+ end loop;
+ end Process_Queued_Events;
+
+ -----------------------
+ -- Insert_Into_Queue --
+ -----------------------
+
+ procedure Insert_Into_Queue (This : Any_Timing_Event) is
+
+ function Sooner (Left, Right : Any_Timing_Event) return Boolean;
+ -- Compares events in terms of timeout values
+
+ package By_Timeout is new Events.Generic_Sorting (Sooner);
+ -- Used to keep the events in ascending order by timeout value
+
+ ------------
+ -- Sooner --
+ ------------
+
+ function Sooner (Left, Right : Any_Timing_Event) return Boolean is
+ begin
+ return Left.Timeout < Right.Timeout;
+ end Sooner;
+
+ -- Start of processing for Insert_Into_Queue
+
+ begin
+ SSL.Abort_Defer.all;
+
+ Write_Lock (Event_Queue_Lock'Access);
+
+ All_Events.Append (This);
+
+ -- A critical property of the implementation of this package is that
+ -- all occurrences are in ascending order by Timeout. Thus the first
+ -- event in the queue always has the "next" value for the Timer task
+ -- to use in its delay statement.
+
+ By_Timeout.Sort (All_Events);
+
+ Unlock (Event_Queue_Lock'Access);
+
+ SSL.Abort_Undefer.all;
+ end Insert_Into_Queue;
+
+ -----------------------
+ -- Remove_From_Queue --
+ -----------------------
+
+ procedure Remove_From_Queue (This : Any_Timing_Event) is
+ use Events;
+ Location : Cursor;
+
+ begin
+ SSL.Abort_Defer.all;
+
+ Write_Lock (Event_Queue_Lock'Access);
+
+ Location := All_Events.Find (This);
+
+ if Location /= No_Element then
+ All_Events.Delete (Location);
+ end if;
+
+ Unlock (Event_Queue_Lock'Access);
+
+ SSL.Abort_Undefer.all;
+ end Remove_From_Queue;
+
+ -----------------
+ -- Set_Handler --
+ -----------------
+
+ procedure Set_Handler
+ (Event : in out Timing_Event;
+ At_Time : Time;
+ Handler : Timing_Event_Handler)
+ is
+ begin
+ Remove_From_Queue (Event'Unchecked_Access);
+ Event.Handler := null;
+
+ -- RM D.15(15/2) required that at this point, we check whether the time
+ -- has already passed, and if so, call Handler.all directly from here
+ -- instead of doing the enqueuing below. However, this caused a nasty
+ -- race condition and potential deadlock. If the current task has
+ -- already locked the protected object of Handler.all, and the time has
+ -- passed, deadlock would occur. It has been fixed by AI05-0094-1, which
+ -- says that the handler should be executed as soon as possible, meaning
+ -- that the timing event will be executed after the protected action
+ -- finishes (Handler.all should not be called directly from here).
+ -- The same comment applies to the other Set_Handler below.
+
+ if Handler /= null then
+ Event.Timeout := At_Time;
+ Event.Handler := Handler;
+ Insert_Into_Queue (Event'Unchecked_Access);
+ end if;
+ end Set_Handler;
+
+ -----------------
+ -- Set_Handler --
+ -----------------
+
+ procedure Set_Handler
+ (Event : in out Timing_Event;
+ In_Time : Time_Span;
+ Handler : Timing_Event_Handler)
+ is
+ begin
+ Remove_From_Queue (Event'Unchecked_Access);
+ Event.Handler := null;
+
+ -- See comment in the other Set_Handler above
+
+ if Handler /= null then
+ Event.Timeout := Clock + In_Time;
+ Event.Handler := Handler;
+ Insert_Into_Queue (Event'Unchecked_Access);
+ end if;
+ end Set_Handler;
+
+ ---------------------
+ -- Current_Handler --
+ ---------------------
+
+ function Current_Handler
+ (Event : Timing_Event) return Timing_Event_Handler
+ is
+ begin
+ return Event.Handler;
+ end Current_Handler;
+
+ --------------------
+ -- Cancel_Handler --
+ --------------------
+
+ procedure Cancel_Handler
+ (Event : in out Timing_Event;
+ Cancelled : out Boolean)
+ is
+ begin
+ Remove_From_Queue (Event'Unchecked_Access);
+ Cancelled := Event.Handler /= null;
+ Event.Handler := null;
+ end Cancel_Handler;
+
+ -------------------
+ -- Time_Of_Event --
+ -------------------
+
+ function Time_Of_Event (Event : Timing_Event) return Time is
+ begin
+ -- RM D.15(18/2): Time_First must be returned in the event is not set
+
+ return (if Event.Handler = null then Time_First else Event.Timeout);
+ end Time_Of_Event;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (This : in out Timing_Event) is
+ begin
+ -- D.15 (19/2) says finalization clears the event
+
+ This.Handler := null;
+ Remove_From_Queue (This'Unchecked_Access);
+ end Finalize;
+
+begin
+ Initialize_Lock (Event_Queue_Lock'Access, Level => PO_Level);
+ Timer.Start;
+end Ada.Real_Time.Timing_Events;