Warning, /testsuites/ada/tmtests/tm16/tmtest.adb is written in an unsupported language. File is not indexed.
0001 -- SPDX-License-Identifier: BSD-2-Clause
0002
0003 --
0004 -- TMTEST / BODY
0005 --
0006 -- DESCRIPTION:
0007 --
0008 -- This package is the implementation of Test 16 of the RTEMS
0009 -- Timing 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 RTEMS_CALLING_OVERHEAD;
0042 with TEST_SUPPORT;
0043 with TEXT_IO;
0044 with TIMER_DRIVER;
0045 with RTEMS.EVENT;
0046
0047 package body TMTEST is
0048
0049 --
0050 -- INIT
0051 --
0052
0053 procedure INIT (
0054 ARGUMENT : in RTEMS.TASKS.ARGUMENT
0055 ) is
0056 pragma Unreferenced(ARGUMENT);
0057 ID : RTEMS.ID;
0058 STATUS : RTEMS.STATUS_CODES;
0059 begin
0060
0061 TEXT_IO.NEW_LINE( 2 );
0062 TEST_SUPPORT.ADA_TEST_BEGIN;
0063
0064 RTEMS.TASKS.CREATE(
0065 RTEMS.BUILD_NAME( 'T', 'E', 'S', 'T' ),
0066 251,
0067 2048,
0068 RTEMS.DEFAULT_MODES,
0069 RTEMS.DEFAULT_ATTRIBUTES,
0070 ID,
0071 STATUS
0072 );
0073 TEST_SUPPORT.DIRECTIVE_FAILED( STATUS, "TASK_CREATE OF TEST INIT" );
0074
0075 RTEMS.TASKS.START(
0076 ID,
0077 TMTEST.TEST_INIT'ACCESS,
0078 0,
0079 STATUS
0080 );
0081 TEST_SUPPORT.DIRECTIVE_FAILED( STATUS, "TASK_START OF TEST INIT" );
0082
0083 RTEMS.TASKS.DELETE( RTEMS.SELF, STATUS );
0084 TEST_SUPPORT.DIRECTIVE_FAILED( STATUS, "TASK_DELETE OF SELF" );
0085
0086 end INIT;
0087
0088 --
0089 -- TEST_INIT
0090 --
0091
0092 procedure TEST_INIT (
0093 ARGUMENT : in RTEMS.TASKS.ARGUMENT
0094 ) is
0095 pragma Unreferenced(ARGUMENT);
0096 PRIORITY : RTEMS.TASKS.PRIORITY;
0097 TASK_ENTRY : RTEMS.TASKS.ENTRY_POINT;
0098 STATUS : RTEMS.STATUS_CODES;
0099 begin
0100
0101 PRIORITY := 250;
0102
0103 for INDEX in 0 .. TIME_TEST_SUPPORT.OPERATION_COUNT
0104 loop
0105
0106 RTEMS.TASKS.CREATE(
0107 RTEMS.BUILD_NAME( 'M', 'I', 'D', ' ' ),
0108 PRIORITY,
0109 1024,
0110 RTEMS.DEFAULT_MODES,
0111 RTEMS.DEFAULT_ATTRIBUTES,
0112 TMTEST.TASK_ID( INDEX ),
0113 STATUS
0114 );
0115 TEST_SUPPORT.DIRECTIVE_FAILED( STATUS, "TASK_CREATE LOOP" );
0116
0117 if INDEX = TIME_TEST_SUPPORT.OPERATION_COUNT then
0118 TASK_ENTRY := TMTEST.HIGH_TASK'ACCESS;
0119 else
0120 TASK_ENTRY := TMTEST.MIDDLE_TASKS'ACCESS;
0121 end if;
0122
0123 RTEMS.TASKS.START(
0124 TMTEST.TASK_ID( INDEX ),
0125 TASK_ENTRY,
0126 0,
0127 STATUS
0128 );
0129 TEST_SUPPORT.DIRECTIVE_FAILED( STATUS, "TASK_START LOOP" );
0130
0131 PRIORITY := PRIORITY - 1;
0132
0133 end loop;
0134
0135 TMTEST.TASK_COUNT := 0;
0136
0137 TIMER_DRIVER.INITIALIZE; -- starts the timer
0138
0139 RTEMS.EVENT.SEND( -- preempts task
0140 TMTEST.TASK_ID( TMTEST.TASK_COUNT ),
0141 RTEMS.EVENT_16,
0142 STATUS
0143 );
0144 TEST_SUPPORT.DIRECTIVE_FAILED( STATUS, "EVENT_SEND" );
0145
0146 end TEST_INIT;
0147
0148 --
0149 -- MIDDLE_TASKS
0150 --
0151
0152 procedure MIDDLE_TASKS (
0153 ARGUMENT : in RTEMS.TASKS.ARGUMENT
0154 ) is
0155 pragma Unreferenced(ARGUMENT);
0156 EVENT_OUT : RTEMS.EVENT_SET;
0157 STATUS : RTEMS.STATUS_CODES;
0158 begin
0159
0160 RTEMS.EVENT.RECEIVE( -- task blocks
0161 RTEMS.EVENT_16,
0162 RTEMS.DEFAULT_OPTIONS,
0163 RTEMS.NO_TIMEOUT,
0164 EVENT_OUT,
0165 STATUS
0166 );
0167 TEST_SUPPORT.DIRECTIVE_FAILED( STATUS, "EVENT_RECEIVE" );
0168
0169 TMTEST.TASK_COUNT := TMTEST.TASK_COUNT + 1;
0170
0171 RTEMS.EVENT.SEND( -- preempts task
0172 TMTEST.TASK_ID( TMTEST.TASK_COUNT ),
0173 RTEMS.EVENT_16,
0174 STATUS
0175 );
0176 TEST_SUPPORT.DIRECTIVE_FAILED( STATUS, "EVENT_SEND" );
0177
0178 end MIDDLE_TASKS;
0179
0180 --
0181 -- HIGH_TASK
0182 --
0183
0184 procedure HIGH_TASK (
0185 ARGUMENT : in RTEMS.TASKS.ARGUMENT
0186 ) is
0187 pragma Unreferenced(ARGUMENT);
0188 EVENT_OUT : RTEMS.EVENT_SET;
0189 STATUS : RTEMS.STATUS_CODES;
0190 begin
0191
0192 RTEMS.EVENT.RECEIVE( -- task blocks
0193 RTEMS.EVENT_16,
0194 RTEMS.DEFAULT_OPTIONS,
0195 RTEMS.NO_TIMEOUT,
0196 EVENT_OUT,
0197 STATUS
0198 );
0199
0200 TMTEST.END_TIME := TIMER_DRIVER.READ_TIMER;
0201
0202 TIME_TEST_SUPPORT.PUT_TIME(
0203 "EVENT_SEND (preemptive)",
0204 TMTEST.END_TIME,
0205 TIME_TEST_SUPPORT.OPERATION_COUNT,
0206 0,
0207 RTEMS_CALLING_OVERHEAD.EVENT_SEND
0208 );
0209
0210 TEST_SUPPORT.ADA_TEST_END;
0211 RTEMS.SHUTDOWN_EXECUTIVE( 0 );
0212
0213 end HIGH_TASK;
0214
0215 end TMTEST;
