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

4.104.115
Last change on this file since 110e1f1 was 110e1f1, checked in by Joel Sherrill <joel.sherrill@…>, on Dec 14, 2009 at 9:17:59 PM

2009-12-14 Joel Sherrill <joel.sherrill@…>

  • samples/base_sp/sptest.adb, samples/hello/sptest.adb, samples/nsecs/sptest.adb, samples/ticker/sptest.adb, sptests/sp01/sptest.adb, sptests/sp02/sptest.adb, sptests/sp03/sptest.adb, sptests/sp04/sptest.adb, sptests/sp05/sptest.adb, sptests/sp06/sptest.adb, sptests/sp07/sptest.adb, sptests/sp08/sptest.adb, sptests/sp09/sptest.adb, sptests/sp11/sptest.adb, sptests/sp12/sptest.adb, sptests/sp13/sptest.adb, sptests/sp14/sptest.adb, sptests/sp15/sptest.adb, sptests/sp16/sptest.adb, sptests/sp17/sptest.adb, sptests/sp19/sptest.adp, sptests/sp20/sptest.adb, sptests/sp22/sptest.adb, sptests/sp23/sptest.adb, sptests/sp24/sptest.adb, sptests/sp25/sptest.adb, sptests/spname01/spname01.adb, sptests/spname01/sptest.adb, sptests/spname01/sptest.ads, support/address_io.adb, support/init.c, support/test_support.adb, support/test_support.ads, support/time_test_support.adb, support/timer_driver.adb, tmtests/tm01/tmtest.adb, tmtests/tm01/tmtest.ads, tmtests/tm02/tmtest.adb, tmtests/tm02/tmtest.ads, tmtests/tm03/tmtest.adb, tmtests/tm03/tmtest.ads, tmtests/tm04/tmtest.adb, tmtests/tm04/tmtest.ads, tmtests/tm05/tmtest.adb, tmtests/tm05/tmtest.ads, tmtests/tm06/tmtest.adb, tmtests/tm06/tmtest.ads, tmtests/tm07/tmtest.adb, tmtests/tm07/tmtest.ads, tmtests/tm08/tmtest.adb, tmtests/tm08/tmtest.ads, tmtests/tm09/tmtest.adb, tmtests/tm09/tmtest.ads, tmtests/tm10/tmtest.adb, tmtests/tm10/tmtest.ads, tmtests/tm11/tmtest.adb, tmtests/tm11/tmtest.ads, tmtests/tm12/tmtest.adb, tmtests/tm12/tmtest.ads, tmtests/tm13/tmtest.adb, tmtests/tm13/tmtest.ads, tmtests/tm14/tmtest.adb, tmtests/tm14/tmtest.ads, tmtests/tm15/tmtest.adb, tmtests/tm15/tmtest.ads, tmtests/tm16/tmtest.adb, tmtests/tm16/tmtest.ads, tmtests/tm17/tmtest.adb, tmtests/tm17/tmtest.ads, tmtests/tm18/tmtest.adb, tmtests/tm18/tmtest.ads, tmtests/tm19/tmtest.adb, tmtests/tm19/tmtest.ads, tmtests/tm20/tmtest.adb, tmtests/tm20/tmtest.ads, tmtests/tm21/tmtest.adb, tmtests/tm21/tmtest.ads, tmtests/tm22/tmtest.adb, tmtests/tm22/tmtest.ads, tmtests/tm23/tmtest.adb, tmtests/tm23/tmtest.ads, tmtests/tm24/tmtest.adb, tmtests/tm24/tmtest.ads, tmtests/tm25/tmtest.adb, tmtests/tm25/tmtest.ads, tmtests/tm28/tmtest.adb, tmtests/tm28/tmtest.ads, tmtests/tm29/tmtest.adb, tmtests/tm29/tmtest.ads, tmtests/tmck/tmtest.adb, tmtests/tmck/tmtest.ads, tmtests/tmoverhd/dummy_rtems.adb, tmtests/tmoverhd/tmtest.adb, tmtests/tmoverhd/tmtest.ads: Remove many warnings.
  • Property mode set to 100644
File size: 6.0 KB
Line 
1--
2--  Test_Support / Specification
3--
4--  DESCRIPTION:
5--
6--  This package provides routines which aid the Test Suites
7--  and simplify their design and operation.
8--
9--  DEPENDENCIES:
10--
11-- 
12--
13--  COPYRIGHT (c) 1989-2009.
14--  On-Line Applications Research Corporation (OAR).
15--
16--  The license and distribution terms for this file may in
17--  the file LICENSE in this distribution or at
18--  http://www.rtems.com/license/LICENSE.
19--
20--  $Id$
21--
22
23with Interfaces; use Interfaces;
24with Unsigned32_IO;
25with Status_IO;
26with Text_IO;
27
28package body Test_Support is
29
30--PAGE
31--
32--  Fatal_Directive_Status
33--
34
35   procedure Fatal_Directive_Status (
36      Status  : in     RTEMS.Status_Codes;
37      Desired : in     RTEMS.Status_Codes;
38      Message : in     String
39   ) is
40   begin
41
42      if not RTEMS.Are_Statuses_Equal( Status, Desired ) then
43
44         Text_IO.Put( Message );
45         Text_IO.Put( " FAILED -- expected " );
46         Status_IO.Put( Desired );
47         Text_IO.Put( " got " );
48         Status_IO.Put( Status );
49         Text_IO.New_Line;
50
51         RTEMS.Fatal_Error_Occurred( RTEMS.Status_Codes'Pos( Status ) );
52
53      end if;
54
55   end Fatal_Directive_Status;
56
57--PAGE
58--
59--  Directive_Failed
60--
61
62   procedure Directive_Failed (
63      Status  : in     RTEMS.Status_Codes;
64      Message : in     String
65   ) is
66   begin
67
68      Test_Support.Fatal_Directive_Status(
69         Status, 
70         RTEMS.Successful, 
71         Message
72      );
73
74   end Directive_Failed;
75
76--PAGE
77--
78--  Print_Time
79--
80
81   procedure Print_Time (
82      Prefix      : in     String;
83      Time_Buffer : in     RTEMS.Time_Of_Day;
84      Suffix      : in     String
85   ) is
86   begin
87
88      Text_IO.Put( Prefix );
89      Unsigned32_IO.Put( Time_Buffer.Hour, Width=>2 );
90      Text_IO.Put( ":" );
91      Unsigned32_IO.Put( Time_Buffer.Minute, Width=>2 );
92      Text_IO.Put( ":" );
93      Unsigned32_IO.Put( Time_Buffer.Second, Width=>2 );
94      Text_IO.Put( "   " );
95      Unsigned32_IO.Put( Time_Buffer.Month, Width=>2 );
96      Text_IO.Put( "/" );
97      Unsigned32_IO.Put( Time_Buffer.Day, Width=>2 );
98      Text_IO.Put( "/" );
99      Unsigned32_IO.Put( Time_Buffer.Year, Width=>2 );
100      Text_IO.Put( Suffix );
101
102   end Print_Time;
103
104--PAGE
105--
106--  Put_Dot
107--
108 
109   procedure Put_Dot (
110      Buffer : in     String
111   ) is
112   begin
113      Text_IO.Put( Buffer );
114      Text_IO.FLUSH;
115   end Put_Dot;
116
117--PAGE
118--
119--  Pause
120--
121
122   procedure Pause is
123      --  Ignored_String : String( 1 .. 80 );
124      --  Ignored_Last   : Natural;
125     
126   begin
127
128      --
129      --  Really should be a "put" followed by a "flush."
130      --
131      Text_IO.Put_Line( "<pause> " );
132      -- Text_IO.Get_Line( Ignored_String, Ignored_Last );
133
134   -- exception
135
136   --    when Text_IO.End_Error =>
137   --    -- ignore this error.  It happens when redirecting input from /dev/null
138   --    return;
139
140   end Pause;
141
142--PAGE
143--
144--  Pause_And_Screen_Number
145--
146 
147   procedure Pause_And_Screen_Number (
148      SCREEN : in    RTEMS.Unsigned32
149   ) is
150      --  Ignored_String : String( 1 .. 80 );
151      --  Ignored_Last   : Natural;
152   begin
153 
154      --
155      --  Really should be a "put" followed by a "flush."
156      --
157      Text_IO.Put( "<pause - screen  " );
158      Unsigned32_IO.Put( SCREEN, Width=>2 );
159      Text_IO.Put_Line( "> " );
160   --    Text_IO.Get_Line( Ignored_String, Ignored_Last );
161 
162   -- exception
163
164   --    when Text_IO.End_Error =>
165   --    -- ignore this error.  It happens when redirecting input from /dev/null
166   --    return;
167
168   end Pause_And_Screen_Number;
169
170--PAGE
171--
172--  Put_Name
173--
174
175   procedure Put_Name (
176      Name     : in     RTEMS.Name;
177      New_Line : in     Boolean
178   ) is
179      C1 : Character;
180      C2 : Character;
181      C3 : Character;
182      C4 : Character;
183   begin
184
185      RTEMS.Name_To_Characters( Name, C1, C2, C3, C4 );
186
187      Text_IO.Put( C1 );
188      Text_IO.Put( C2 );
189      Text_IO.Put( C3 );
190      Text_IO.Put( C4 );
191
192      if New_Line then
193         Text_IO.New_Line;
194      end if;
195
196   end Put_Name;
197 
198--PAGE
199--
200--  Task_Number
201--
202
203   function Task_Number (
204      TID : in     RTEMS.ID
205   ) return RTEMS.Unsigned32 is
206   begin
207
208      -- probably OK
209      return RTEMS.Get_Index( TID ) - 1;
210      --   Ignoring this component.
211      --   - RTEMS.Configuration.RTEMS_API_Configuration.Number_Of_Initialization_Tasks;
212
213   end Task_Number;
214
215--PAGE
216--
217--  Do_Nothing
218--
219
220   procedure Do_Nothing is
221   begin
222      NULL;
223   end Do_Nothing;
224   
225
226--PAGE
227--
228--  Milliseconds_Per_Tick
229--
230
231   function Milliseconds_Per_Tick 
232   return RTEMS.Unsigned32 is
233      function Milliseconds_Per_Tick_Base return RTEMS.Unsigned32;
234      pragma Import (C, Milliseconds_Per_Tick_Base, "milliseconds_per_tick");
235   begin
236      return Milliseconds_Per_Tick_Base;
237   end Milliseconds_Per_Tick;
238
239--PAGE
240--
241--  Milliseconds_Per_Tick
242--
243   function Ticks_Per_Second 
244   return RTEMS.Interval is
245      function Ticks_Per_Second_Base return RTEMS.Unsigned32;
246      pragma Import (C, Ticks_Per_Second_Base, "ticks_per_second");
247   begin
248      return Ticks_Per_Second_Base;
249   end Ticks_Per_Second; 
250
251--
252--  Return the size of the RTEMS Workspace
253--
254
255   function Work_Space_Size
256   return RTEMS.Unsigned32 is 
257      function Work_Space_Size_Base return RTEMS.Unsigned32;
258      pragma Import (C, Work_Space_Size_Base, "work_space_size");
259   begin
260      return Work_Space_Size_Base;
261   end Work_Space_Size;
262
263--
264--  Return an indication of whether multiprocessing is configured
265--
266
267   function Is_Configured_Multiprocessing
268   return Boolean is
269      function Is_Configured_Multiprocessing_Base return RTEMS.Unsigned32;
270      pragma Import (
271         C, Is_Configured_Multiprocessing_Base, "is_configured_multiprocessing"
272      );
273   begin
274      if Is_Configured_Multiprocessing_Base = 1 then
275         return True;
276      else
277         return False;
278      end if;
279   end Is_Configured_Multiprocessing;
280
281--
282--  Node is the node number in a multiprocessor configuration
283--
284
285   function Node 
286   return RTEMS.Unsigned32 is
287      function Get_Node_Base return RTEMS.Unsigned32;
288      pragma Import (C, Get_Node_Base, "get_node");
289   begin
290      return Get_Node_Base;
291   end Node;
292end Test_Support;
Note: See TracBrowser for help on using the repository browser.