------------------------------------------------------------------------------
--                                                                          --
--                 GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS               --
--                                                                          --
--                      S Y S T E M . R E A L _ T I M E                     --
--                                                                          --
--                                  B o d y                                 --
--                                                                          --
--                             $Revision: 1.7 $                             --
--                                                                          --
--           Copyright (c) 1991,1992,1993, FSU, All Rights Reserved         --
--                                                                          --
--  GNARL is free software; you can redistribute it and/or modify it  under --
--  terms  of  the  GNU  Library General Public License as published by the --
--  Free Software Foundation; either version 2,  or  (at  your  option) any --
--  later  version.   GNARL is distributed in the hope that it will be use- --
--  ful, but but WITHOUT ANY WARRANTY; without even the implied warranty of --
--  MERCHANTABILITY  or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Gen- --
--  eral Library Public License for more details.  You should have received --
--  a  copy of the GNU Library General Public License along with GNARL; see --
--  file COPYING. If not, write to the Free Software Foundation,  675  Mass --
--  Ave, Cambridge, MA 02139, USA.                                          --
--                                                                          --
------------------------------------------------------------------------------

pragma Checks_On;
--  We require checks on for this body, because we rely on the constraint
--  error to keep System.Real_Time.Time values within representable range.

with System.Compiler_Exceptions;
--  Uses, function Current_Exceptions

with System.Task_Timer_Service;
--  Uses, object Objects
--        procedure Service_Entries

with System.Tasking;

with Unchecked_Conversion;

package body System.Real_Time is

   use Task_Clock;
   --  Using it for arithmetic operations

   use Tasking.Protected_Objects;
   use Tasking;

   package Timer renames System.Task_Timer_Service.Timer;

   function To_Access is new
     Unchecked_Conversion (System.Address, Protection_Access);

   -----------
   -- Clock --
   -----------

   function Clock return Time is
   begin
      return Time (Task_Clock.Machine_Specifics.Clock);
   end Clock;

   ---------
   -- "<" --
   ---------

   function "<" (Left, Right : Time) return Boolean is
   begin
      return Task_Clock.Stimespec (Left) < Task_Clock.Stimespec (Right);
   end "<";

   function "<" (Left, Right : Time_Span) return Boolean is
   begin
      return Task_Clock.Stimespec (Left) < Task_Clock.Stimespec (Right);
   end "<";

   ---------
   -- ">" --
   ---------

   function ">" (Left, Right : Time) return Boolean is
   begin
      return Right < Left;
   end ">";

   function ">" (Left, Right : Time_Span) return Boolean is
   begin
      return Right < Left;
   end ">";

   ----------
   -- "<=" --
   ----------

   function "<=" (Left, Right : Time) return Boolean is
   begin
      return not (Left > Right);
   end "<=";

   function "<=" (Left, Right : Time_Span) return Boolean is
   begin
      return not (Left > Right);
   end "<=";

   ----------
   -- ">=" --
   ----------

   function ">=" (Left, Right : Time) return Boolean is
   begin
      return not (Left < Right);
   end ">=";

   function ">=" (Left, Right : Time_Span) return Boolean is
   begin
      return not (Left < Right);
   end ">=";

   ---------
   -- "+" --
   ---------

   --  Note that Constraint_Error may be propagated

   function "+" (Left : Time; Right : Time_Span) return Time is
   begin
      return Time (Task_Clock.Stimespec (Left) + Task_Clock.Stimespec (Right));
   end "+";

   function "+"  (Left : Time_Span; Right : Time) return Time is
   begin
      return Right + Left;
   end "+";

   function "+"  (Left, Right : Time_Span) return Time_Span is
   begin
      return Time_Span (Time (Right) + Left);
   end "+";

   ---------
   -- "-" --
   ---------

   --  Note that Constraint_Error may be propagated

   function "-"  (Left : Time; Right : Time_Span) return Time is
   begin
      return Time (Task_Clock.Stimespec (Left) - Task_Clock.Stimespec (Right));
   end "-";

   function "-"  (Left, Right : Time) return Time_Span is
   begin
      return Time_Span (Left - Time_Span (Right));
   end "-";

   function "-"  (Left, Right : Time_Span) return Time_Span is
   begin
      return Time_Span (Time (Left) - Right);
   end "-";

   function "-"  (Right : Time_Span) return Time_Span is
   begin
      return Time_Span (-(Task_Clock.Stimespec (Right)));
   end "-";

   ---------
   -- "/" --
   ---------

   --  Note that Constraint_Error may be propagated

   function "/"  (Left, Right : Time_Span) return integer is
      Temp_TV : Task_Clock.Stimespec;

   begin
      Temp_TV := Task_Clock.Stimespec (Left) / Task_Clock.Stimespec (Right);

      if not (Temp_TV < Task_Clock.Stimespec_Zero)  then
         return Task_Clock.Stimespec_Seconds (Temp_TV);
      end if;

      Temp_TV := -Temp_TV;
      return -Task_Clock.Stimespec_Seconds (Temp_TV);
   end "/";

   function "/"  (Left : Time_Span; Right : Integer) return Time_Span is
   begin
      return Time_Span (Task_Clock.Stimespec (Left) / Right);
   end "/";

   ---------
   -- "*" --
   ---------

   --  Note that Constraint_Error may be propagated

   function "*"  (Left : Time_Span; Right : Integer) return Time_Span is
   begin
      return Time_Span (Task_Clock.Stimespec (Left) * Right);
   end "*";

   function "*"  (Left : Integer; Right : Time_Span) return Time_Span is
   begin
      return Right * Left;
   end "*";

   -----------
   -- "abs" --
   -----------

   --  Note that Constraint_Error may be propagated

   function "abs" (Right : Time_Span) return Time_Span is
   begin
      if Right < Time_Span_Zero then
         return -Right;
      end if;

      return Right;
   end "abs";

   -----------------
   -- To_Duration --
   -----------------

   function To_Duration (FD : Time_Span) return Duration is
   begin
      return Task_Clock.Stimespec_To_Duration (Task_Clock.Stimespec (FD));
   end To_Duration;

   ------------------
   -- To_Time_Span --
   ------------------

   function To_Time_Span (D : Duration) return Time_Span is
   begin
      return Time_Span (Task_Clock.Duration_To_Stimespec (D));
   end To_Time_Span;

   -----------------
   -- Nanoseconds --
   -----------------

   function Nanoseconds (NS : integer) return Time_Span is
   begin
      return Time_Span_Unit * NS;
   end Nanoseconds;

   ------------------
   -- Microseconds --
   ------------------

   function Microseconds  (US : integer) return Time_Span is
   begin
      return Nanoseconds (US) * 1000;
   end Microseconds;

   -------------------
   --  Milliseconds --
   -------------------

   function Milliseconds (MS : integer) return Time_Span is
   begin
      return Microseconds (MS) * 1000;
   end Milliseconds;

   ------------------
   -- Delay_Object --
   ------------------

   --  Hand translated code will be provided here
   --  until the GNAT compiler can accomodate the protected objects. ???

   package body Delay_Object is

      procedure Service_Entries (Pending_Serviced : out Boolean) is
         P : System.Address;

         subtype PO_Entry_Index is Protected_Entry_Index
           range Null_Protected_Entry .. 1;

         Barriers : Barrier_Vector (1 .. 1)  :=  (others => true);
         --  No barriers. always true barrier

         E : PO_Entry_Index;

         PS : Boolean;

         Cumulative_PS : Boolean := False;

      begin
         loop
            --  Get the next queued entry or the pending call
            --  (if no barriers are true)

            Next_Entry_Call (To_Access (Object'Address), Barriers, P, E);

            begin
               case E is
                  when Null_Protected_Entry =>  --  no call to serve
                     exit;

                  when 1 =>

                     --  Lock the object before requeueing

                     Lock (To_Access (Timer.Object'Address));

                  --  9X code ???
                  --  requeue Timer.Enqueue (clock.Clock+Time (FD)) with abort;

                     begin
                        Requeue_Protected_Entry (
                          Object => To_Access (Object'Address),
                          New_Object => To_Access (Timer.Object'Address),
                          E => 1,
                          With_Abort => true);

                        --  Requeue on the timer for the service. Parameter is
                        --  passed along as Object.Call_In_Progress.Param

                        Timer.Service_Entries (PS);

                     --  Neither Requeue nor Service_Entries should raise
                     --  an exception; the exception should be saved. ???

--                   exception
--                      when others =>
--                         Timer.Service_Entries(PS);
--                         raise;
                     end;
               end case;

            exception
               when others =>
                  Tasking.Protected_Objects.Exceptional_Complete_Entry_Body (
                    Object => To_Access (Object'Address),
                    Ex => Compiler_Exceptions.Current_Exception,
                    Pending_Serviced => PS);
            end;

            Cumulative_PS := Cumulative_PS or PS;

         end loop;

         Pending_Serviced := Cumulative_PS;
      end Service_Entries;

   begin
      Initialize_Protection (
        To_Access (Object'Address),
        Tasking.Unspecified_Priority);
   end Delay_Object;

   -----------
   -- Split --
   -----------

   --  D is nonnegative Time_Span

   procedure Split (T : Time; S : out Seconds; D : out Time_Span) is
      Temp_S : Seconds;

   begin
      Temp_S :=
        Seconds (Task_Clock.Stimespec_Seconds (Task_Clock.Stimespec (T)));
      S := Temp_S;
      D := Time_Span (T) -
           (integer (Temp_S) * Time_Span (Task_Clock.Stimespec_Sec_Unit));
   end Split;

   -------------
   -- Time_Of --
   -------------

   function Time_Of (S : Seconds; D : Time_Span) return Time is
   begin
      return Time (integer (S) *
            Time_Span (Task_Clock.Stimespec_Sec_Unit) + D);
   end Time_Of;

end System.Real_Time;
