-- 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 1: Integer, float, and access types, procedures and functions. -- -- TEST DESCRIPTION: -- Subtests are: -- (A) Scalar parameters to procedures. -- (B) Scalar parameters to functions. -- (C) Access parameters to procedures. -- (D) Access parameters to functions. -- -- For the procedure 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. -- -- To completely test this objective, we should also try in out and out -- parameters for functions (Ada 2012), in/in out/out parameters for -- task and protected entries, and a variety of different scalar types -- (enumeration, modular, fixed, decimal). -- -- CHANGE HISTORY: -- 14 Jan 1980 DAS Created test. -- 26 Oct 1982 SPS -- 25 May 1984 CPP -- 29 Oct 1985 EG Eliminate the use of Numeric_Error in the test. -- 14 Mar 2014 RLB Revised so test cases are legal for Ada 2012, modernized -- objective, converted to modern format, added float cases. with Report; procedure C620001 is use Report; begin Test ("C620001", "Check that elementary parameters are passed by copy"); -------------------------------------------------- declare -- (A) I,J,K : Natural := Report.Ident_Int(1); -- Index values. Arr : array (1 .. 4) of Integer; E : exception; procedure P (PI : in Integer; PO : out Integer; PIO : in out Integer) is Tmp : Integer; begin Tmp := PI; -- Save value of PI at procedure entry. PO := 10; if (PI /= Tmp) then Failed ("Assignement to scalar out " & "parameter changes the value of " & "input parameter"); Tmp := PI; -- Reset Tmp for next case. end if; PIO := PIO + 100; if (PI /= Tmp) then Failed ("Assignment to scalar in out " & "parameter changes the value of " & "inputparameter"); Tmp := PI; -- Reset Tmp for next case. end if; Arr(I) := Arr(I) + 1; if (PI /= Tmp) then Failed ("Assignment to scalar actual " & "parameter changes the value of " & "input parameter"); end if; raise E; -- Check exception handling. end P; begin -- (A) Arr := (others => 0); P (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"); when 101 => Failed ("In out actual scalar " & "parameter changed global value"); when 111 => Failed ("Out and in out actual scalar " & "parameters changed global " & "value"); when others => Failed ("Uundetermined change to global " & "value"); end case; end if; when others => Failed ("Wrong exception raised - A"); end; -- (A) -------------------------------------------------- declare -- (B) I,J : Integer; function F (FI : in Integer) return Integer is Tmp : Integer := FI; begin I := I + 1; if (FI /= Tmp) then Failed ("Assignment to scalar actual function " & "parameter changes the value of " & "input parameter"); end if; return (100); end F; begin -- (B) I := 100; J := F (I); 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; procedure P (PI : in Acctype; PO : out Acctype; PIO : in out Acctype) is Tmp : Acctype; begin Tmp := PI; -- Save value of PI at procedure entry. Arr(I) := new Integer'(101); if (PI /= Tmp) then Failed ("Assignment to access actual " & "parameter changes the value of " & "input parameter"); Tmp := PI; -- Reset Tmp for next case. end if; PO := new Integer'(1); if (PI /= Tmp) then Failed ("Assignment to access out " & "parameter changes the value of " & "input parameter"); Tmp := PI; -- Reset Tmp for next case. end if; PIO := new Integer'(10); if (PI /= Tmp) then Failed ("Assignment to access in out " & "parameter changes the value of " & "input parameter"); end if; raise E; -- Check exception handling. end P; begin -- (C) Arr(I) := new Integer'(100); P (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 procedure " & "parameter value changed despite " & "raised exception"); end if; when others => Failed ("Wrong exception raised - C"); end; -- (C) -------------------------------------------------- declare -- (D) Type Acctype is access Integer; I,J : Acctype; function F (FI : in Acctype) return Acctype is Tmp : Acctype := FI; begin I := new Integer; if (FI /= Tmp) then Failed ("Assignment to access actual function " & "parameter changes the value of " & "Input parameter"); end if; return null; end F; begin -- (D) I := null; J := F(I); end; -- (D) -------------------------------------------------- declare -- (E) I,J,K : Natural := Report.Ident_Int(3); -- Index values. Arr : array (1 .. 3) of Float; E : exception; procedure P (PI : in Float; PO : out Float; PIO : in out Float) is Tmp : Float; begin Tmp := PI; -- Save value of PI at procedure entry. PO := 0.5; if (PI /= Tmp) then Failed ("Assignement to float out " & "parameter changes the value of " & "input parameter"); Tmp := PI; -- Reset Tmp for next case. end if; PIO := PIO + 0.25; if (PI /= Tmp) then Failed ("Assignment to float in out " & "parameter changes the value of " & "inputparameter"); Tmp := PI; -- Reset Tmp for next case. end if; Arr(I) := Arr(I) + 1.0; if (PI /= Tmp) then Failed ("Assignment to float actual " & "parameter changes the value of " & "input parameter"); end if; raise E; -- Check exception handling. end P; begin -- (E) Arr := (others => 0.0); P (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"); end if; when others => Failed ("Wrong exception raised - E"); end; -- (E) -------------------------------------------------- declare -- (F) I,J : Float; function F (FI : in Float) return Float is Tmp : Float := FI; begin I := I + 1.0; if (FI /= Tmp) then Failed ("Assignment to float actual function " & "parameter changes the value of " & "input parameter"); end if; return 100.0; end F; begin -- (F) I := 100.0; J := F (I); end; -- (F) -------------------------------------------------- Result; end C620001;