From 31d7a8bd3d322870543d960e7f8e7b909d7e4950 Mon Sep 17 00:00:00 2001 From: Pat Rogers Date: Wed, 15 Feb 2006 10:33:57 +0100 Subject: [PATCH] a-rttiev.adb, [...]: New files. 2006-02-13 Pat Rogers * a-rttiev.adb, a-rttiev.ads: New files. From-SVN: r111040 --- gcc/ada/a-rttiev.adb | 328 +++++++++++++++++++++++++++++++++++++++++++ gcc/ada/a-rttiev.ads | 128 +++++++++++++++++ 2 files changed, 456 insertions(+) create mode 100644 gcc/ada/a-rttiev.adb create mode 100644 gcc/ada/a-rttiev.ads diff --git a/gcc/ada/a-rttiev.adb b/gcc/ada/a-rttiev.adb new file mode 100644 index 00000000000..f28af4e011b --- /dev/null +++ b/gcc/ada/a-rttiev.adb @@ -0,0 +1,328 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2006, 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Tasking.Utilities; +-- for Make_Independent + +with Ada.Containers.Doubly_Linked_Lists; +pragma Elaborate_All (Ada.Containers.Doubly_Linked_Lists); + +package body Ada.Real_Time.Timing_Events is + + 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); + + ----------------- + -- Event_Queue -- + ----------------- + + protected Event_Queue is + pragma Priority (System.Priority'Last); + + procedure Insert (This : Any_Timing_Event); + -- Inserts This into the queue in ascending order by Timeout + + procedure Process_Events; + -- Iterates over the list of events and calls the handlers for any of + -- those that have timed out. Deletes those that have timed out. + + private + All_Events : Events.List; + end Event_Queue; + + ----------- + -- 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. + + begin + System.Tasking.Utilities.Make_Independent; + loop + Event_Queue.Process_Events; + delay until Clock + Period; + end loop; + end Timer; + + ------------ + -- Sooner -- + ------------ + + function Sooner (Left, Right : Any_Timing_Event) return Boolean; + -- Used by the Event_Queue insertion routine to keep the events in + -- ascending order by timeout value. + + ----------------- + -- Event_Queue -- + ----------------- + + protected body Event_Queue is + + procedure Insert (This : Any_Timing_Event) is + package By_Timeout is new Events.Generic_Sorting (Sooner); + -- Used to keep the events in ascending order by timeout value + + begin + 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); + end Insert; + + procedure Process_Events is + Next_Event : Any_Timing_Event; + begin + while not All_Events.Is_Empty loop + Next_Event := All_Events.First_Element; + + -- Clients can cancel a timeout (setting the handler to null) but + -- cannot otherwise change the timeout/handler tuple until the + -- call to Reset below. + + if Next_Event.Control.Current_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). + + return; + end if; + + declare + Response : Timing_Event_Handler; + + begin + -- We take a local snapshot of the handler to avoid a race + -- condition because we evaluate the handler value in the + -- if-statement and again in the call and the client might have + -- set it to null between those two evaluations. + + Response := Next_Event.Control.Current_Handler; + + if Response /= null then + + -- D.15 (13/2) says we only invoke the handler if it is + -- set when the timeout expires. + + Response (Timing_Event (Next_Event.all)); + end if; + + exception + when others => + null; -- per D.15 (21/2) + end; + + Next_Event.Control.Reset; + + -- Clients can now change the timeout/handler pair for this event + + -- And now we can delete the event from the queue. Any item we + -- delete would be the first in the queue because we exit the loop + -- when we first find one that is not yet timed-out. This fact + -- allows us to use these "First oriented" list processing + -- routines instead of the cursor oriented versions because we can + -- avoid handling the way deletion affects cursors. + + All_Events.Delete_First; + end loop; + end Process_Events; + + end Event_Queue; + + ----------------- + -- Set_Handler -- + ----------------- + + procedure Set_Handler + (Event : in out Timing_Event; + At_Time : Time; + Handler : Timing_Event_Handler) + is + begin + Event.Control.Cancel; + + if At_Time <= Clock then + if Handler /= null then + Handler (Event); + end if; + return; + end if; + + if Handler /= null then + Event.Control.Set (At_Time, Handler); + Event_Queue.Insert (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 + Event.Control.Cancel; + + if In_Time <= Time_Span_Zero then + if Handler /= null then + Handler (Event); + end if; + return; + end if; + + if Handler /= null then + Event.Control.Set (Clock + In_Time, Handler); + Event_Queue.Insert (Event'Unchecked_Access); + end if; + end Set_Handler; + + ----------------- + -- Event_State -- + ----------------- + + protected body Event_State is + + entry Set + (Timeout : Time; + Handler : Timing_Event_Handler) + when + Available + is + begin + Event_State.Timeout := Set.Timeout; + Event_State.Handler := Set.Handler; + Available := False; + end Set; + + procedure Reset is + begin + Cancel; + Available := True; + end Reset; + + procedure Cancel is + begin + Handler := null; + Timeout := Time_First; + end Cancel; + + function Current_Timeout return Time is + begin + return Timeout; + end Current_Timeout; + + function Current_Handler return Timing_Event_Handler is + begin + return Handler; + end Current_Handler; + + end Event_State; + + --------------------- + -- Current_Handler -- + --------------------- + + function Current_Handler + (Event : Timing_Event) return Timing_Event_Handler + is + begin + return Event.Control.Current_Handler; + end Current_Handler; + + -------------------- + -- Cancel_Handler -- + -------------------- + + procedure Cancel_Handler + (Event : in out Timing_Event; + Cancelled : out Boolean) + is + begin + Cancelled := Event.Control.Current_Handler /= null; + Event.Control.Cancel; + end Cancel_Handler; + + ------------------- + -- Time_Of_Event -- + ------------------- + + function Time_Of_Event (Event : Timing_Event) return Time is + begin + return Event.Control.Current_Timeout; + end Time_Of_Event; + + ------------ + -- Sooner -- + ------------ + + function Sooner (Left, Right : Any_Timing_Event) return Boolean is + begin + return Left.Control.Current_Timeout < Right.Control.Current_Timeout; + end Sooner; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (This : in out Timing_Event) is + begin + -- D.15 (19/2) says finalization clears the event + + This.Control.Cancel; + end Finalize; + +end Ada.Real_Time.Timing_Events; diff --git a/gcc/ada/a-rttiev.ads b/gcc/ada/a-rttiev.ads new file mode 100644 index 00000000000..9d114d4f598 --- /dev/null +++ b/gcc/ada/a-rttiev.ads @@ -0,0 +1,128 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Finalization; + +package Ada.Real_Time.Timing_Events is + + type Timing_Event is tagged limited private; + + type Timing_Event_Handler + is access protected procedure (Event : in out Timing_Event); + + procedure Set_Handler + (Event : in out Timing_Event; + At_Time : Time; + Handler : Timing_Event_Handler); + + procedure Set_Handler + (Event : in out Timing_Event; + In_Time : Time_Span; + Handler : Timing_Event_Handler); + + function Current_Handler + (Event : Timing_Event) return Timing_Event_Handler; + + procedure Cancel_Handler + (Event : in out Timing_Event; + Cancelled : out Boolean); + + function Time_Of_Event (Event : Timing_Event) return Time; + +private + + protected type Event_State is + + -- D.15 (22/2) requires atomicity with respect to the operations + -- provided by the package and the timing events they manipulate. On + -- real-time operating systems suitable for implementing this package, a + -- different implementation strategy would be employed to meet that + -- requirement. + + entry Set (Timeout : Time; Handler : Timing_Event_Handler); + -- Changes the timeout and handler values for procedure Set_Handler. Can + -- only execute when the event is 'available', to prevent a race + -- condition between the caller of Set_Handler and the internal Timer + -- task that processes the events. In particular, D.15 (22/2) requires + -- that there be no possibility of a new handler executing in response + -- to an old timeout. + + procedure Reset; + -- First resets the timeout to Time_First and the handler to + -- null. Indicates that Set (for Set_Handler) can now change the timeout + -- and/or handler. Called only by the interal Timer task. + + procedure Cancel; + -- Resets the timeout to Time_First and the handler to + -- null. Called by procedure Cancel_Handler and by procedure Reset. + + function Current_Timeout return Time; + -- Returns the currently set timeout. The value Time_First is returned + -- if the Timing_Event is in the "cleared" state. Called by function + -- Time_of_Event. + + function Current_Handler return Timing_Event_Handler; + -- Returns the currently set handler. The value null is returned if the + -- Timing_Event is in the "cleared" state. Called by function + -- Curent_Handler. + + private + Timeout : Time := Time_First; + -- The time at which the user's handler should be invoked when the + -- event is "set" (i.e., when Handler is not null). + + Handler : Timing_Event_Handler; + -- An access value designating the protected procedure to be invoked + -- at the Timeout time in the future. When this value is null the event + -- is said to be "cleared" and no timeout is processed. + + Available : Boolean := True; + -- A flag controlling when users can change the Timeout and Handler + -- tuple. In particular the entry Set, called by procedure Set_Handler, + -- is controlled by this flag. + + end Event_State; + + type Timing_Event is new Ada.Finalization.Limited_Controlled with record + Control : Event_State; + end record; + + overriding procedure Finalize (This : in out Timing_Event); + -- Finalization procedure is required to satisfy (RM D.15 (19/2)), which + -- says that the object must be cleared on finalization. + +end Ada.Real_Time.Timing_Events; -- 2.30.2