source: rtems/testsuites/ada/support/test_support.adb

-- SPDX-License-Identifier: BSD-2-Clause

--
--  Test_Support / Specification
--
--  DESCRIPTION:
--
--  This package provides routines which aid the Test Suites
--  and simplify their design and operation.
--
--  DEPENDENCIES: 
--
--  
--
--  COPYRIGHT (c) 1989-2011.
--  On-Line Applications Research Corporation (OAR).
--
--  Redistribution and use in source and binary forms, with or without
--  modification, are permitted provided that the following conditions
--  are met:
--  1. Redistributions of source code must retain the above copyright
--     notice, this list of conditions and the following disclaimer.
--  2. Redistributions in binary form must reproduce the above copyright
--     notice, this list of conditions and the following disclaimer in the
--     documentation and/or other materials provided with the distribution.
--
--  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
--  AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
--  IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
--  ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
--  LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
--  CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
--  SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
--  INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
--  CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
--  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
--  POSSIBILITY OF SUCH DAMAGE.
--

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

package body Test_Support is

--
--  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;

--
--  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;

--
--  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;

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

--
--  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 );

   end Pause;

--
--  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 );
 
   end Pause_And_Screen_Number;

--
--  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 then
         Text_IO.New_Line;
      end if;

   end Put_Name;
 
--
--  Task_Number
--

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

      -- probably OK
      return RTEMS.Get_Index( TID ) - 1;

   end Task_Number;

--
--  Do_Nothing
--

   procedure Do_Nothing is
   begin
      NULL;
   end Do_Nothing;
   

--
--  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;

--
--  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; 

--
--  Return the size of the RTEMS Workspace
--

   function Work_Space_Size
   return RTEMS.Size is
      function Work_Space_Size_Base return RTEMS.Size;
      pragma Import (C, Work_Space_Size_Base, "work_space_size");
   begin
      return Work_Space_Size_Base;
   end Work_Space_Size;

--
--  Return an indication of whether multiprocessing is configured
--

   function Is_Configured_Multiprocessing
   return Boolean is
      function Is_Configured_Multiprocessing_Base return RTEMS.Unsigned32;
      pragma Import (
         C, Is_Configured_Multiprocessing_Base, "is_configured_multiprocessing"
      );
   begin
      if Is_Configured_Multiprocessing_Base = 1 then
         return True;
      else
         return False;
      end if;
   end Is_Configured_Multiprocessing;

--
--  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;