Warning, /testsuites/ada/sptests/sp04/sptest.adb is written in an unsupported language. File is not indexed.
0001 -- SPDX-License-Identifier: BSD-2-Clause
0002
0003 --
0004 -- SPTEST / BODY
0005 --
0006 -- DESCRIPTION:
0007 --
0008 -- This package is the implementation of Test 4 of the RTEMS
0009 -- Single Processor Test Suite.
0010 --
0011 -- DEPENDENCIES:
0012 --
0013 --
0014 --
0015 -- COPYRIGHT (c) 1989-2011.
0016 -- On-Line Applications Research Corporation (OAR).
0017 --
0018 -- Redistribution and use in source and binary forms, with or without
0019 -- modification, are permitted provided that the following conditions
0020 -- are met:
0021 -- 1. Redistributions of source code must retain the above copyright
0022 -- notice, this list of conditions and the following disclaimer.
0023 -- 2. Redistributions in binary form must reproduce the above copyright
0024 -- notice, this list of conditions and the following disclaimer in the
0025 -- documentation and/or other materials provided with the distribution.
0026 --
0027 -- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
0028 -- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
0029 -- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
0030 -- ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
0031 -- LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
0032 -- CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
0033 -- SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
0034 -- INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
0035 -- CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
0036 -- ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
0037 -- POSSIBILITY OF SUCH DAMAGE.
0038 --
0039
0040 with INTERFACES; use INTERFACES;
0041 with TEST_SUPPORT;
0042 with TEXT_IO;
0043 with RTEMS.CLOCK;
0044 with RTEMS.EXTENSION;
0045 with RTEMS.FATAL;
0046
0047 package body SPTEST is
0048
0049 TestsFinished : Boolean := False;
0050 pragma Volatile (TestsFinished);
0051
0052 type Task_Event is record
0053 Task_Index : RTEMS.Unsigned32;
0054 When_Switched : RTEMS.Time_Of_Day;
0055 end record;
0056
0057 Task_Events : array (1 .. 15) of Task_Event;
0058 Task_Events_Index : Natural := Task_Events'First;
0059
0060 procedure Log_Task_Event (
0061 Task_Index : RTEMS.Unsigned32;
0062 When_Switched : RTEMS.Time_Of_Day
0063 ) is
0064 begin
0065 if Task_Events_Index = Task_Events'Last then
0066 RTEMS.Fatal.Error_Occurred ( 1 ); -- no other choice
0067 else
0068 Task_Events (Task_Events_Index).Task_Index := Task_Index;
0069 Task_Events (Task_Events_Index).When_Switched := When_Switched;
0070 Task_Events_Index := Task_Events_Index + 1;
0071 end if;
0072 end Log_Task_Event;
0073
0074 procedure Flush_Task_Event_Log is
0075 begin
0076 for I in Task_Events'First .. Task_Events_Index - 1 loop
0077
0078 TEST_SUPPORT.PUT_NAME(
0079 SPTEST.TASK_NAME( Task_Events (I).Task_Index ), FALSE
0080 );
0081 TEST_SUPPORT.PRINT_TIME( "- ", Task_Events (I).When_Switched, "" );
0082 TEXT_IO.NEW_LINE;
0083
0084 end loop;
0085
0086 end Flush_Task_Event_Log;
0087
0088 --
0089 -- INIT
0090 --
0091
0092 procedure INIT (
0093 ARGUMENT : in RTEMS.TASKS.ARGUMENT
0094 ) is
0095 pragma Unreferenced(ARGUMENT);
0096 TIME : RTEMS.TIME_OF_DAY;
0097 STATUS : RTEMS.STATUS_CODES;
0098 begin
0099
0100 TEXT_IO.NEW_LINE( 2 );
0101 TEST_SUPPORT.ADA_TEST_BEGIN;
0102
0103 TIME := ( 1988, 12, 31, 9, 15, 0, 0 );
0104
0105 RTEMS.CLOCK.SET( TIME, STATUS );
0106 TEST_SUPPORT.DIRECTIVE_FAILED( STATUS, "CLOCK_SET" );
0107
0108 SPTEST.EXTENSION_NAME( 1 ) := RTEMS.BUILD_NAME( 'E', 'X', 'T', ' ' );
0109
0110 RTEMS.EXTENSION.CREATE(
0111 SPTEST.EXTENSION_NAME( 1 ),
0112 SPTEST.EXTENSIONS'ACCESS,
0113 EXTENSION_ID( 1 ),
0114 STATUS
0115 );
0116 TEST_SUPPORT.DIRECTIVE_FAILED( STATUS, "EXTENSION_CREATE" );
0117
0118 SPTEST.TASK_NAME( 1 ) := RTEMS.BUILD_NAME( 'T', 'A', '1', ' ' );
0119 SPTEST.TASK_NAME( 2 ) := RTEMS.BUILD_NAME( 'T', 'A', '2', ' ' );
0120 SPTEST.TASK_NAME( 3 ) := RTEMS.BUILD_NAME( 'T', 'A', '3', ' ' );
0121
0122 SPTEST.RUN_COUNT( 1 ) := 0;
0123 SPTEST.RUN_COUNT( 2 ) := 0;
0124 SPTEST.RUN_COUNT( 3 ) := 0;
0125
0126 RTEMS.TASKS.CREATE(
0127 SPTEST.TASK_NAME( 1 ),
0128 1,
0129 2048,
0130 RTEMS.TIMESLICE,
0131 RTEMS.DEFAULT_ATTRIBUTES,
0132 SPTEST.TASK_ID( 1 ),
0133 STATUS
0134 );
0135 TEST_SUPPORT.DIRECTIVE_FAILED( STATUS, "TASK_CREATE OF TA1" );
0136
0137 RTEMS.TASKS.CREATE(
0138 SPTEST.TASK_NAME( 2 ),
0139 1,
0140 2048,
0141 RTEMS.TIMESLICE,
0142 RTEMS.DEFAULT_ATTRIBUTES,
0143 SPTEST.TASK_ID( 2 ),
0144 STATUS
0145 );
0146 TEST_SUPPORT.DIRECTIVE_FAILED( STATUS, "TASK_CREATE OF TA2" );
0147
0148 RTEMS.TASKS.CREATE(
0149 SPTEST.TASK_NAME( 3 ),
0150 1,
0151 2048,
0152 RTEMS.TIMESLICE,
0153 RTEMS.DEFAULT_ATTRIBUTES,
0154 SPTEST.TASK_ID( 3 ),
0155 STATUS
0156 );
0157 TEST_SUPPORT.DIRECTIVE_FAILED( STATUS, "TASK_CREATE OF TA3" );
0158
0159 RTEMS.TASKS.START(
0160 SPTEST.TASK_ID( 1 ),
0161 SPTEST.TASK_1'ACCESS,
0162 0,
0163 STATUS
0164 );
0165 TEST_SUPPORT.DIRECTIVE_FAILED( STATUS, "TASK_START OF TA1" );
0166
0167 RTEMS.TASKS.START(
0168 SPTEST.TASK_ID( 2 ),
0169 SPTEST.TASK_2'ACCESS,
0170 0,
0171 STATUS
0172 );
0173 TEST_SUPPORT.DIRECTIVE_FAILED( STATUS, "TASK_START OF TA2" );
0174
0175 RTEMS.TASKS.START(
0176 SPTEST.TASK_ID( 3 ),
0177 SPTEST.TASK_3'ACCESS,
0178 0,
0179 STATUS
0180 );
0181 TEST_SUPPORT.DIRECTIVE_FAILED( STATUS, "TASK_START OF TA3" );
0182
0183 RTEMS.TASKS.DELETE( RTEMS.SELF, STATUS );
0184 TEST_SUPPORT.DIRECTIVE_FAILED( STATUS, "TASK_DELETE OF SELF" );
0185
0186 end INIT;
0187
0188 --
0189 -- TASK_1
0190 --
0191
0192 procedure TASK_1 (
0193 ARGUMENT : in RTEMS.TASKS.ARGUMENT
0194 ) is
0195 pragma Unreferenced(ARGUMENT);
0196 SECONDS : RTEMS.UNSIGNED32;
0197 OLD_SECONDS : RTEMS.UNSIGNED32;
0198 PREVIOUS_MODE : RTEMS.MODE;
0199 TIME : RTEMS.TIME_OF_DAY;
0200 START_TIME : RTEMS.INTERVAL;
0201 END_TIME : RTEMS.INTERVAL;
0202 STATUS : RTEMS.STATUS_CODES;
0203 begin
0204
0205 TEXT_IO.PUT_LINE( "TA1 - task_suspend - on Task 2" );
0206 RTEMS.TASKS.SUSPEND( TASK_ID( 2 ), STATUS );
0207 TEST_SUPPORT.DIRECTIVE_FAILED( STATUS, "TASK_SUSPEND OF TA2" );
0208
0209 TEXT_IO.PUT_LINE( "TA1 - task_suspend - on Task 3" );
0210 RTEMS.TASKS.SUSPEND( TASK_ID( 3 ), STATUS );
0211 TEST_SUPPORT.DIRECTIVE_FAILED( STATUS, "TASK_SUSPEND OF TA3" );
0212
0213 TEXT_IO.PUT_LINE( "TA1 - killing time" );
0214
0215 RTEMS.CLOCK.GET_SECONDS_SINCE_EPOCH( START_TIME, STATUS );
0216 TEST_SUPPORT.DIRECTIVE_FAILED( STATUS, "CLOCK_GET_SECONDS_SINCE_EPOCH" );
0217
0218 loop
0219 RTEMS.CLOCK.GET_SECONDS_SINCE_EPOCH( END_TIME, STATUS );
0220 TEST_SUPPORT.DIRECTIVE_FAILED(STATUS, "CLOCK_GET_SECONDS_SINCE_EPOCH");
0221
0222 exit when END_TIME > (START_TIME + 2);
0223 end loop;
0224
0225 TEXT_IO.PUT_LINE( "TA1 - task_resume - on Task 2" );
0226 RTEMS.TASKS.RESUME( TASK_ID( 2 ), STATUS );
0227 TEST_SUPPORT.DIRECTIVE_FAILED( STATUS, "TASK_RESUME OF TA2" );
0228
0229 TEXT_IO.PUT_LINE( "TA1 - task_resume - on Task 3" );
0230 RTEMS.TASKS.RESUME( TASK_ID( 3 ), STATUS );
0231 TEST_SUPPORT.DIRECTIVE_FAILED( STATUS, "TASK_RESUME OF TA3" );
0232
0233 loop
0234
0235 if SPTEST.RUN_COUNT( 1 ) = 3 then
0236
0237 TEXT_IO.PUT_LINE(
0238 "TA1 - task_mode - change mode to NO PREEMPT"
0239 );
0240 RTEMS.TASKS.MODE(
0241 RTEMS.NO_PREEMPT,
0242 RTEMS.PREEMPT_MASK,
0243 PREVIOUS_MODE,
0244 STATUS
0245 );
0246 TEST_SUPPORT.DIRECTIVE_FAILED( STATUS, "TASK_MODE" );
0247
0248 RTEMS.CLOCK.GET_TOD( TIME, STATUS );
0249 TEST_SUPPORT.DIRECTIVE_FAILED( STATUS, "CLOCK_GET_TOD" );
0250
0251 OLD_SECONDS := TIME.SECOND;
0252
0253 SECONDS := 0;
0254 loop
0255
0256 exit when SECONDS >= 6;
0257
0258 RTEMS.CLOCK.GET_TOD( TIME, STATUS );
0259 TEST_SUPPORT.DIRECTIVE_FAILED( STATUS, "CLOCK_GET_TOD" );
0260
0261 if TIME.SECOND /= OLD_SECONDS then
0262 OLD_SECONDS := TIME.SECOND;
0263 SECONDS := SECONDS + 1;
0264 TEST_SUPPORT.PRINT_TIME( "TA1 - ", TIME, "" );
0265 TEXT_IO.NEW_LINE;
0266 end if;
0267
0268 end loop;
0269
0270 TEXT_IO.PUT_LINE(
0271 "TA1 - task_mode - change mode to PREEMPT"
0272 );
0273
0274 RTEMS.TASKS.MODE(
0275 RTEMS.PREEMPT,
0276 RTEMS.PREEMPT_MASK,
0277 PREVIOUS_MODE,
0278 STATUS
0279 );
0280 TEST_SUPPORT.DIRECTIVE_FAILED( STATUS, "TASK_MODE" );
0281
0282 while not TestsFinished loop
0283 NULL;
0284 END LOOP;
0285 Flush_Task_Event_Log;
0286 TEST_SUPPORT.ADA_TEST_END;
0287 RTEMS.SHUTDOWN_EXECUTIVE( 0 );
0288
0289 end if;
0290
0291 end loop;
0292
0293 end TASK_1;
0294
0295 --
0296 -- TASK_2
0297 --
0298
0299 procedure TASK_2 (
0300 ARGUMENT : in RTEMS.TASKS.ARGUMENT
0301 ) is
0302 pragma Unreferenced(ARGUMENT);
0303 begin
0304
0305 LOOP
0306 NULL;
0307 END LOOP;
0308
0309 end TASK_2;
0310
0311 --
0312 -- TASK_3
0313 --
0314
0315 procedure TASK_3 (
0316 ARGUMENT : in RTEMS.TASKS.ARGUMENT
0317 ) is
0318 pragma Unreferenced(ARGUMENT);
0319 begin
0320
0321 LOOP
0322 NULL;
0323 END LOOP;
0324
0325 end TASK_3;
0326
0327 --
0328 -- TASK_SWITCH
0329 --
0330
0331 procedure TASK_SWITCH (
0332 UNUSED : in RTEMS.TCB_POINTER;
0333 HEIR : in RTEMS.TCB_POINTER
0334 ) is
0335 pragma Unreferenced(UNUSED);
0336 INDEX : RTEMS.UNSIGNED32;
0337 TIME : RTEMS.TIME_OF_DAY;
0338 STATUS : RTEMS.STATUS_CODES;
0339 function TCB_To_ID (
0340 TCB : RTEMS.TCB_POINTER
0341 ) return RTEMS.ID;
0342 pragma Import (C, TCB_To_ID, "tcb_to_id" );
0343
0344 begin
0345
0346 INDEX := TEST_SUPPORT.TASK_NUMBER( TCB_To_ID( HEIR ) );
0347
0348 case INDEX is
0349 when 1 | 2 | 3 =>
0350 SPTEST.RUN_COUNT( INDEX ) := SPTEST.RUN_COUNT( INDEX ) + 1;
0351
0352 RTEMS.CLOCK.GET_TOD( TIME, STATUS );
0353 TEST_SUPPORT.DIRECTIVE_FAILED( STATUS, "CLOCK_GET_TOD" );
0354
0355 Log_Task_Event ( INDEX, TIME );
0356
0357 if TIME.SECOND >= 16 then
0358 TestsFinished := True;
0359 end if;
0360
0361 when others =>
0362 NULL;
0363 end case;
0364
0365 end TASK_SWITCH;
0366
0367 end SPTEST;
