source: rtems/c/src/ada-tests/support/test_support.adb @ d14963b

--
--  Test_Support / Specification
--
--  DESCRIPTION:
--
--  This package provides routines which aid the Test Suites
--  and simplify their design and operation.
--
--  DEPENDENCIES: 
--
--  
--
--  COPYRIGHT (c) 1989-1997.
--  On-Line Applications Research Corporation (OAR).
--
--  The license and distribution terms for this file may in
--  the file LICENSE in this distribution or at
--  http://www.rtems.com/license/LICENSE.
--
--  $Id$
--

with Interfaces; use Interfaces;
with RTEMS;
with Unsigned32_IO;
with Status_IO;
with Text_IO;

package body Test_Support is

--PAGE
--
--  Fatal_Directive_Status
--

   procedure Fatal_Directive_Status (
      Status  : in     RTEMS.Status_Codes;
      Desired : in     RTEMS.Status_Codes;
      Message : in     String
   ) is
   begin

      if not RTEMS.Are_Statuses_Equal( Status, Desired ) then

         Text_IO.Put( Message );
         Text_IO.Put( " FAILED -- expected " );
         Status_IO.Put( Desired );
         Text_IO.Put( " got " );
         Status_IO.Put( Status );
         Text_IO.New_Line;

         RTEMS.Fatal_Error_Occurred( RTEMS.Status_Codes'Pos( Status ) );

      end if;

   end Fatal_Directive_Status;

--PAGE
--
--  Directive_Failed
--

   procedure Directive_Failed (
      Status  : in     RTEMS.Status_Codes;
      Message : in     String
   ) is
   begin

      Test_Support.Fatal_Directive_Status(
         Status, 
         RTEMS.Successful, 
         Message 
      );

   end Directive_Failed;

--PAGE
--
--  Print_Time
--

   procedure Print_Time (
      Prefix      : in     String;
      Time_Buffer : in     RTEMS.Time_Of_Day;
      Suffix      : in     String
   ) is
   begin

      Text_IO.Put( Prefix );
      Unsigned32_IO.Put( Time_Buffer.Hour, Width=>2 );
      Text_IO.Put( ":" );
      Unsigned32_IO.Put( Time_Buffer.Minute, Width=>2 );
      Text_IO.Put( ":" );
      Unsigned32_IO.Put( Time_Buffer.Second, Width=>2 );
      Text_IO.Put( "   " );
      Unsigned32_IO.Put( Time_Buffer.Month, Width=>2 );
      Text_IO.Put( "/" );
      Unsigned32_IO.Put( Time_Buffer.Day, Width=>2 );
      Text_IO.Put( "/" );
      Unsigned32_IO.Put( Time_Buffer.Year, Width=>2 );
      Text_IO.Put( Suffix );

   end Print_Time;

--PAGE
--
--  Put_Dot
--
 
   procedure Put_Dot (
      Buffer : in     String
   ) is
   begin
      Text_IO.Put( Buffer );
      Text_IO.FLUSH;
   end Put_Dot;

--PAGE
--
--  Pause
--

   procedure Pause is
      --  Ignored_String : String( 1 .. 80 );
      --  Ignored_Last   : Natural;
      
   begin

      -- 
      --  Really should be a "put" followed by a "flush."
      -- 
      Text_IO.Put_Line( "<pause> " );
      -- Text_IO.Get_Line( Ignored_String, Ignored_Last );

   -- exception

   --    when Text_IO.End_Error =>
   --    -- ignore this error.  It happens when redirecting input from /dev/null 
   --    return;

   end Pause;

--PAGE
--
--  Pause_And_Screen_Number
--
 
   procedure Pause_And_Screen_Number (
      SCREEN : in    RTEMS.Unsigned32
   ) is
      --  Ignored_String : String( 1 .. 80 );
      --  Ignored_Last   : Natural;
   begin
 
      --
      --  Really should be a "put" followed by a "flush."
      --
      Text_IO.Put( "<pause - screen  " );
      Unsigned32_IO.Put( SCREEN, Width=>2 );
      Text_IO.Put_Line( "> " );
   --    Text_IO.Get_Line( Ignored_String, Ignored_Last );
 
   -- exception

   --    when Text_IO.End_Error =>
   --    -- ignore this error.  It happens when redirecting input from /dev/null 
   --    return;

   end Pause_And_Screen_Number;

--PAGE
--
--  Put_Name
--

   procedure Put_Name (
      Name     : in     RTEMS.Name;
      New_Line : in     Boolean
   ) is
      C1 : Character;
      C2 : Character;
      C3 : Character;
      C4 : Character;
   begin

      RTEMS.Name_To_Characters( Name, C1, C2, C3, C4 );

      Text_IO.Put( C1 );
      Text_IO.Put( C2 );
      Text_IO.Put( C3 );
      Text_IO.Put( C4 );

      if New_Line = True then
         Text_IO.New_Line;
      end if;

   end Put_Name;
 
--PAGE
--
--  Task_Number
--

   function Task_Number (
      TID : in     RTEMS.ID
   ) return RTEMS.Unsigned32 is
   begin

      -- probably OK
      return RTEMS.Get_Index( TID ) - 1;
      --   Ignoring this component.
      --   - RTEMS.Configuration.RTEMS_API_Configuration.Number_Of_Initialization_Tasks;

   end Task_Number;

--PAGE
--
--  Do_Nothing
--

   procedure Do_Nothing is
   begin
      NULL;
   end Do_Nothing;
   

--PAGE
--
--  Milliseconds_Per_Tick
--

   function Milliseconds_Per_Tick 
   return RTEMS.Unsigned32 is
      function Milliseconds_Per_Tick_Base return RTEMS.Unsigned32;
      pragma Import (C, Milliseconds_Per_Tick_Base, "milliseconds_per_tick");
   begin
      return Milliseconds_Per_Tick_Base;
   end Milliseconds_Per_Tick;

--PAGE
--
--  Milliseconds_Per_Tick
--
   function Ticks_Per_Second 
   return RTEMS.Interval is
      function Ticks_Per_Second_Base return RTEMS.Unsigned32;
      pragma Import (C, Ticks_Per_Second_Base, "ticks_per_second");
   begin
      return Ticks_Per_Second_Base;
   end Ticks_Per_Second; 

--
--  Node is the node number in a multiprocessor configuration
--

   function Node 
   return RTEMS.Unsigned32 is
      function Get_Node_Base return RTEMS.Unsigned32;
      pragma Import (C, Get_Node_Base, "get_node");
   begin
      return Get_Node_Base;
   end Node;
end Test_Support;