Warning, /testsuites/ada/mptests/mp07/mptest.adb is written in an unsupported language. File is not indexed.
0001 -- SPDX-License-Identifier: BSD-2-Clause
0002
0003 --
0004 -- MPTEST / BODY
0005 --
0006 -- DESCRIPTION:
0007 --
0008 -- This package is the implementation for Test 7 of the RTEMS
0009 -- Multiprocessor 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.EVENT;
0042 with RTEMS.TIMER;
0043 with TEST_SUPPORT;
0044 with TEXT_IO;
0045 with UNSIGNED32_IO;
0046
0047 package body MPTEST is
0048
0049 --
0050 -- INIT
0051 --
0052
0053 procedure INIT (
0054 ARGUMENT : in RTEMS.TASKS.ARGUMENT
0055 ) is
0056 pragma Unreferenced(ARGUMENT);
0057 STATUS : RTEMS.STATUS_CODES;
0058 begin
0059
0060 TEXT_IO.NEW_LINE( 2 );
0061 TEST_SUPPORT.ADA_TEST_BEGIN;
0062 TEXT_IO.PUT( "*** NODE " );
0063 UNSIGNED32_IO.PUT(
0064 TEST_SUPPORT.NODE,
0065 WIDTH => 1
0066 );
0067 TEXT_IO.PUT_LINE( " ***" );
0068
0069 MPTEST.TASK_NAME( 1 ) := RTEMS.BUILD_NAME( '1', '1', '1', ' ' );
0070 MPTEST.TASK_NAME( 2 ) := RTEMS.BUILD_NAME( '2', '2', '2', ' ' );
0071
0072 TEXT_IO.PUT_LINE( "Creating Test_task (Global)" );
0073 RTEMS.TASKS.CREATE(
0074 MPTEST.TASK_NAME( TEST_SUPPORT.NODE ),
0075 TEST_SUPPORT.NODE,
0076 2048,
0077 RTEMS.TIMESLICE,
0078 RTEMS.GLOBAL,
0079 MPTEST.TASK_ID( 1 ),
0080 STATUS
0081 );
0082 TEST_SUPPORT.DIRECTIVE_FAILED( STATUS, "TASK_CREATE" );
0083
0084 TEXT_IO.PUT_LINE( "Starting Test_task (Global)" );
0085 RTEMS.TASKS.START(
0086 MPTEST.TASK_ID( 1 ),
0087 MPTEST.TEST_TASK'ACCESS,
0088 0,
0089 STATUS
0090 );
0091 TEST_SUPPORT.DIRECTIVE_FAILED( STATUS, "TASK_START" );
0092
0093 MPTEST.TIMER_NAME( 1 ) := RTEMS.BUILD_NAME( 'T', 'M', '1', ' ' );
0094
0095 RTEMS.TIMER.CREATE(
0096 MPTEST.TIMER_NAME( 1 ),
0097 MPTEST.TIMER_ID( 1 ),
0098 STATUS
0099 );
0100 TEST_SUPPORT.DIRECTIVE_FAILED( STATUS, "TIMER_CREATE" );
0101
0102 TEXT_IO.PUT_LINE( "Deleting initialization task" );
0103 RTEMS.TASKS.DELETE( RTEMS.SELF, STATUS );
0104 TEST_SUPPORT.DIRECTIVE_FAILED( STATUS, "TASK_DELETE OF SELF" );
0105
0106 end INIT;
0107
0108 --
0109 -- STOP_TEST_TSR
0110 --
0111
0112 procedure STOP_TEST_TSR (
0113 IGNORED1 : in RTEMS.ID;
0114 IGNORED2 : in RTEMS.ADDRESS
0115 ) is
0116 begin
0117
0118 MPTEST.STOP_TEST := TRUE;
0119
0120 end STOP_TEST_TSR;
0121
0122 --
0123 -- TEST_TASK
0124 --
0125
0126 procedure TEST_TASK (
0127 ARGUMENT : in RTEMS.TASKS.ARGUMENT
0128 ) is
0129 pragma Unreferenced(ARGUMENT);
0130 EVENT_OUT : RTEMS.EVENT_SET;
0131 STATUS : RTEMS.STATUS_CODES;
0132 begin
0133
0134 MPTEST.STOP_TEST := FALSE;
0135
0136 if TEST_SUPPORT.NODE = 1 then
0137 MPTEST.REMOTE_NODE := 2;
0138 else
0139 MPTEST.REMOTE_NODE := 1;
0140 end if;
0141
0142 TEXT_IO.PUT( "Remote task's name is : " );
0143 TEST_SUPPORT.PUT_NAME( MPTEST.TASK_NAME( MPTEST.REMOTE_NODE ), TRUE );
0144
0145 TEXT_IO.PUT_LINE( "Getting TID of remote task" );
0146 loop
0147 RTEMS.TASKS.IDENT(
0148 MPTEST.TASK_NAME( MPTEST.REMOTE_NODE ),
0149 RTEMS.SEARCH_ALL_NODES,
0150 MPTEST.REMOTE_TID,
0151 STATUS
0152 );
0153
0154 exit when RTEMS.ARE_STATUSES_EQUAL( STATUS, RTEMS.SUCCESSFUL );
0155
0156 end loop;
0157
0158 if TEST_SUPPORT.NODE = 1 then
0159
0160 TEXT_IO.PUT_LINE( "Sending first event to remote task" );
0161 RTEMS.EVENT.SEND(
0162 MPTEST.REMOTE_TID,
0163 RTEMS.EVENT_16,
0164 STATUS
0165 );
0166 TEST_SUPPORT.DIRECTIVE_FAILED( STATUS, "EVENT_SEND" );
0167
0168 end if;
0169
0170 RTEMS.TIMER.FIRE_AFTER(
0171 MPTEST.TIMER_ID( 1 ),
0172 5 * TEST_SUPPORT.TICKS_PER_SECOND,
0173 MPTEST.STOP_TEST_TSR'ACCESS,
0174 RTEMS.NULL_ADDRESS,
0175 STATUS
0176 );
0177 TEST_SUPPORT.DIRECTIVE_FAILED( STATUS, "TIMER_FIRE_AFTER" );
0178
0179 loop
0180
0181 exit when MPTEST.STOP_TEST;
0182
0183 for COUNT in 1 .. MPTEST.PER_DOT
0184 loop
0185
0186 RTEMS.EVENT.RECEIVE(
0187 RTEMS.EVENT_16,
0188 RTEMS.DEFAULT_OPTIONS,
0189 TEST_SUPPORT.TICKS_PER_SECOND,
0190 EVENT_OUT,
0191 STATUS
0192 );
0193 if RTEMS.ARE_STATUSES_EQUAL( STATUS, RTEMS.TIMEOUT ) then
0194 TEXT_IO.NEW_LINE;
0195 TEXT_IO.PUT_LINE(
0196 "TA1 - TIMEOUT .. probably OK if the other node exits"
0197 );
0198 exit;
0199 else
0200 TEST_SUPPORT.DIRECTIVE_FAILED( STATUS, "EVENT_RECEIVE" );
0201 end if;
0202
0203 RTEMS.EVENT.SEND(
0204 MPTEST.REMOTE_TID,
0205 RTEMS.EVENT_16,
0206 STATUS
0207 );
0208 TEST_SUPPORT.DIRECTIVE_FAILED( STATUS, "EVENT_SEND" );
0209
0210 end loop;
0211
0212 TEST_SUPPORT.PUT_DOT( "." );
0213
0214 end loop;
0215
0216 TEXT_IO.NEW_LINE;
0217
0218 TEST_SUPPORT.ADA_TEST_END;
0219
0220 RTEMS.SHUTDOWN_EXECUTIVE( 0 );
0221
0222 end TEST_TASK;
0223
0224 end MPTEST;
