LXR 6.1/​testsuites/​ada/​support/​test_support.adb	Source navigation Diff markup Identifier search General search
	Version: 6.1 Revert   Change

Warning, /testsuites/ada/support/test_support.adb is written in an unsupported language. File is not indexed.

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

This page was automatically generated by the 2.3.7 LXR engine. The LXR team