-- C620001.A
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
-- OBJECTIVE:
-- Check that elementary parameters are passed by copy.
--
-- Part 2: Integer, float, and access types, task and protected entries.
--
-- TEST DESCRIPTION:
-- Subtests are:
-- (A) Scalar parameters to task entries.
-- (B) Scalar parameters to protected entries.
-- (C) Access parameters to task entries.
-- (D) Access parameters to protected entries.
--
-- For all of these examples, we pass array elements indexed by dynamically
-- determined indexes. Doing this side-steps the check of 6.4.1(6.15/3) and
-- makes the test more realistic.
--
-- Note: This is based on legacy test C95072A.ADA (which was withdrawn).
--
-- CHANGE HISTORY:
-- 22 Jul 1985 DAS Created test.
-- 12 May 2020 RLB Revised so test cases are legal for Ada 2012, modernized
-- objective, converted to modern format, added float
-- and protected cases.
with Report;
procedure C620002 is
use Report;
begin
Test ("C620002", "Check that elementary parameters are passed by copy," &
" part 2 - task and protected entries");
--------------------------------------------------
declare -- (A)
I,J,K : Natural := Report.Ident_Int (1); -- Index values.
Arr : array (1 .. 4) of Integer;
E : exception;
task TA is
entry EA (EI : in Integer;
EO : out Integer;
EIO : in out Integer);
end TA;
task body TA is
Tmp : Integer;
begin
accept EA (EI : in Integer;
EO : out Integer;
EIO : in out Integer) do
Tmp := EI; -- Save value of EI at accept.
EO := 10;
if EI /= Tmp then
Failed ("Assignement to scalar out " &
"parameter changes the value of " &
"input parameter - A");
Tmp := EI; -- Reset Tmp for next case.
end if;
EIO := EIO + 100;
if EI /= Tmp then
Failed ("Assignment to scalar in out " &
"parameter changes the value of " &
"input parameter - A");
Tmp := EI; -- Reset Tmp for next case.
end if;
Arr(I) := Arr(I) + 1;
if EI /= Tmp then
Failed ("Assignment to scalar actual " &
"parameter changes the value of " &
"input parameter - A");
end if;
raise E; -- Check exception handling.
end EA;
exception
when others => null;
end TA;
begin -- (A)
Arr := (others => 0);
TA.EA (Arr(I), Arr(J), Arr(K));
Failed ("Exception not raised - A");
exception
when E =>
if Arr(I) /= 1 then
case Arr(I) is
when 11 =>
Failed ("Out actual scalar parameter " &
"changed global value - A");
when 101 =>
Failed ("In out actual scalar " &
"parameter changed global value - A");
when 111 =>
Failed ("Out and in out actual scalar " &
"parameters changed global " &
"value - A");
when others =>
Failed ("Undetermined change to global " &
"value - A");
end case;
end if;
when others =>
Failed ("Wrong exception raised - A");
end; -- (A)
--------------------------------------------------
declare -- (B)
I,J,K : Natural := Report.Ident_Int (3); -- Index values.
Arr : array (1 .. 5) of Integer;
E : exception;
protected PA is
entry EA (EI : in Integer;
EO : out Integer;
EIO : in out Integer);
end PA;
protected body PA is
entry EA (EI : in Integer;
EO : out Integer;
EIO : in out Integer) when True is
Tmp : Integer;
begin
Tmp := EI; -- Save value of EI at entry.
EO := 10;
if EI /= Tmp then
Failed ("Assignement to scalar out " &
"parameter changes the value of " &
"input parameter - B");
Tmp := EI; -- Reset Tmp for next case.
end if;
EIO := EIO + 100;
if EI /= Tmp then
Failed ("Assignment to scalar in out " &
"parameter changes the value of " &
"input parameter - B");
Tmp := EI; -- Reset Tmp for next case.
end if;
Arr(I) := Arr(I) + 1;
if EI /= Tmp then
Failed ("Assignment to scalar actual " &
"parameter changes the value of " &
"input parameter - B");
end if;
raise E; -- Check exception handling.
end EA;
end PA;
begin -- (B)
Arr := (others => 0);
PA.EA (Arr(I), Arr(J), Arr(K));
Failed ("Exception not raised - B");
exception
when E =>
if Arr(I) /= 1 then
case Arr(I) is
when 11 =>
Failed ("Out actual scalar parameter " &
"changed global value - B");
when 101 =>
Failed ("In out actual scalar " &
"parameter changed global value - B");
when 111 =>
Failed ("Out and in out actual scalar " &
"parameters changed global " &
"value - B");
when others =>
Failed ("Undetermined change to global " &
"value - B");
end case;
end if;
when others =>
Failed ("Wrong exception raised - B");
end; -- (B)
--------------------------------------------------
declare -- (C)
type Acctype is access Integer;
I,J,K : Natural := Report.Ident_Int (2); -- Index values.
Arr : array (1 .. 5) of Acctype;
E : exception;
task TB is
entry EB (EI : in Acctype;
EO : out Acctype;
EIO : in out Acctype);
end TB;
task body TB is
Tmp : Acctype;
begin
accept EB (EI : in Acctype;
EO : out Acctype;
EIO : in out Acctype) do
Tmp := EI; -- Save value of EI at accept.
Arr(I) := new Integer'(101);
if EI /= Tmp then
Failed ("Assignment to access actual " &
"parameter changes the value of " &
"input parameter - C");
Tmp := EI; -- Reset Tmp for next case.
end if;
EO := new Integer'(1);
if EI /= Tmp then
Failed ("Assignment to access out " &
"parameter changes the value of " &
"input parameter - C");
Tmp := EI; -- Reset Tmp for next case.
end if;
EIO := new Integer'(10);
if EI /= Tmp then
Failed ("Assignment to access in out " &
"parameter changes the value of " &
"input parameter - C");
end if;
raise E; -- Check exception handling.
end EB;
exception
when others => null;
end TB;
begin -- (C)
Arr(I) := new Integer'(100);
TB.EB (Arr(I), Arr(J), Arr(K));
Failed ("Exception not raised - C");
exception
when E =>
if (Arr(I).all /= 101) then
Failed ("Out or in out actual " &
"parameter value changed despite " &
"raised exception - C");
end if;
when others =>
Failed ("Wrong exception raised - C");
end; -- (C)
--------------------------------------------------
declare -- (D)
type Acctype is access Integer;
I,J,K : Natural := Report.Ident_Int (4); -- Index values.
Arr : array (1 .. 6) of Acctype;
E : exception;
protected PB is
entry EB (EI : in Acctype;
EO : out Acctype;
EIO : in out Acctype);
end PB;
protected body PB is
entry EB (EI : in Acctype;
EO : out Acctype;
EIO : in out Acctype) when True is
Tmp : Acctype;
begin
Tmp := EI; -- Save value of EI at entry.
Arr(I) := new Integer'(101);
if EI /= Tmp then
Failed ("Assignment to access actual " &
"parameter changes the value of " &
"input parameter - D");
Tmp := EI; -- Reset Tmp for next case.
end if;
EO := new Integer'(1);
if EI /= Tmp then
Failed ("Assignment to access out " &
"parameter changes the value of " &
"input parameter - D");
Tmp := EI; -- Reset Tmp for next case.
end if;
EIO := new Integer'(10);
if EI /= Tmp then
Failed ("Assignment to access in out " &
"parameter changes the value of " &
"input parameter - D");
end if;
raise E; -- Check exception handling.
end EB;
end PB;
begin -- (D)
Arr(I) := new Integer'(100);
PB.EB (Arr(I), Arr(J), Arr(K));
Failed ("Exception not raised - D");
exception
when E =>
if (Arr(I).all /= 101) then
Failed ("Out or in out actual " &
"parameter value changed despite " &
"raised exception - D");
end if;
when others =>
Failed ("Wrong exception raised - D");
end; -- (D)
--------------------------------------------------
declare -- (E)
I,J,K : Natural := Report.Ident_Int (3); -- Index values.
Arr : array (1 .. 3) of Float;
E : exception;
task TC is
entry EC (EI : in Float;
EO : out Float;
EIO : in out Float);
end TC;
task body TC is
Tmp : Float;
begin
accept EC (EI : in Float;
EO : out Float;
EIO : in out Float) do
Tmp := EI; -- Save value of EI at accept.
EO := 0.5;
if EI /= Tmp then
Failed ("Assignement to float out " &
"parameter changes the value of " &
"input parameter - E");
Tmp := EI; -- Reset Tmp for next case.
end if;
EIO := EIO + 0.25;
if EI /= Tmp then
Failed ("Assignment to float in out " &
"parameter changes the value of " &
"input parameter - E");
Tmp := EI; -- Reset Tmp for next case.
end if;
Arr(I) := Arr(I) + 1.0;
if EI /= Tmp then
Failed ("Assignment to float actual " &
"parameter changes the value of " &
"input parameter - E");
end if;
raise E; -- Check exception handling.
end EC;
exception
when others => null;
end TC;
begin -- (E)
Arr := (others => 0.0);
TC.EC (Arr(I), Arr(J), Arr(K));
Failed ("Exception not raised - E");
exception
when E =>
if (Arr(I) /= 1.0) then
Failed ("Out or in out actual procedure " &
"parameter value changed despite " &
"raised exception - E");
end if;
when others =>
Failed ("Wrong exception raised - E");
end; -- (E)
--------------------------------------------------
declare -- (F)
I,J,K : Natural := Report.Ident_Int (6); -- Index values.
Arr : array (1 .. 7) of Float;
E : exception;
protected PC is
entry EC (EI : in Float;
EO : out Float;
EIO : in out Float);
end PC;
protected body PC is
entry EC (EI : in Float;
EO : out Float;
EIO : in out Float) when True is
Tmp : Float;
begin
Tmp := EI; -- Save value of EI at entry.
EO := 0.5;
if EI /= Tmp then
Failed ("Assignement to float out " &
"parameter changes the value of " &
"input parameter - F");
Tmp := EI; -- Reset Tmp for next case.
end if;
EIO := EIO + 0.25;
if EI /= Tmp then
Failed ("Assignment to float in out " &
"parameter changes the value of " &
"input parameter - F");
Tmp := EI; -- Reset Tmp for next case.
end if;
Arr(I) := Arr(I) + 1.0;
if EI /= Tmp then
Failed ("Assignment to float actual " &
"parameter changes the value of " &
"input parameter - F");
end if;
raise E; -- Check exception handling.
end EC;
end PC;
begin -- (F)
Arr := (others => 0.0);
PC.EC (Arr(I), Arr(J), Arr(K));
Failed ("Exception not raised - F");
exception
when E =>
if (Arr(I) /= 1.0) then
Failed ("Out or in out actual procedure " &
"parameter value changed despite " &
"raised exception - F");
end if;
when others =>
Failed ("Wrong exception raised - F");
end; -- (F)
--------------------------------------------------
Result;
end C620002;