This repository has been archived on 2024-12-16. You can view files and clone it, but cannot push or open issues or pull requests.
CodeBlocksPortable/MinGW/lib/gcc/mingw32/6.3.0/adainclude/a-rttiev.adb

368 lines
12 KiB
Ada

------------------------------------------------------------------------------
-- --
-- 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-2014, 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
-- We need to Initialize_Lock before Timer is activated. The purpose of the
-- Dummy package is to get around Ada's syntax rules.
package Dummy is end Dummy;
package body Dummy is
begin
Initialize_Lock (Event_Queue_Lock'Access, Level => PO_Level);
end Dummy;
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);
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.
Ignore : constant Boolean := System.Tasking.Utilities.Make_Independent;
pragma Unreferenced (Ignore);
begin
-- 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;
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;
end Ada.Real_Time.Timing_Events;