diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/cxb')
33 files changed, 9591 insertions, 0 deletions
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb2001.a b/gcc/testsuite/ada/acats/tests/cxb/cxb2001.a new file mode 100644 index 000000000..73f9209cd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb2001.a @@ -0,0 +1,633 @@ +-- CXB2001.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 subprograms Shift_Left, Shift_Right, +-- Shift_Right_Arithmetic, Rotate_Left, and Rotate_Right are available +-- and produce correct results for values of signed and modular +-- integer types of 8 bits. +-- +-- TEST DESCRIPTION: +-- This test uses the shift and rotate functions of package Interfaces +-- with a modular type representative of 8 bits. The functions +-- are used as the right hand of assignment statements, as part of +-- conditional statements, and as arguments in other function calls. +-- +-- A check is performed in the test to determine whether the bit +-- ordering method used by the machine/implementation is high-order +-- first ("Big Endian") or low-order first ("Little Endian"). The +-- specific subtests use this information to evaluate the results of +-- each of the functions under test. +-- +-- Note: In the string associated with each Report.Failed statement, the +-- acronym BE refers to Big Endian, LE refers to Little Endian. +-- +-- APPLICABILITY CRITERIA: +-- This test is applicable to all implementations that support signed +-- and modular integer types of 8 bits. +-- +-- +-- CHANGE HISTORY: +-- 21 Aug 95 SAIC Initial prerelease version. +-- 07 May 96 SAIC Incorporated reviewer comments for ACVC 2.1. +-- +--! + +with Report; +with Interfaces; +with Ada.Exceptions; + +procedure CXB2001 is +begin + + Report.Test ("CXB2001", + "Check that subprograms Shift_Left, Shift_Right, " & + "Shift_Right_Arithmetic, Rotate_Left, and Rotate_Right " & + "produce correct results for values of signed and " & + "modular integer types of 8 bits"); + + Test_Block: + declare + + use Ada.Exceptions; + use Interfaces; + + TC_Amount : Natural := Natural'First; + Big_Endian : Boolean := False; + + -- Range of type Unsigned_8 is 0..255 (0..Modulus-1). + TC_Val_Unsigned_8, + TC_Result_Unsigned_8 : Unsigned_8 := Unsigned_8'First; + + begin + + -- Determine whether the machine uses high-order first or low-order + -- first bit ordering. + -- On a high-order first machine, bit zero of a storage element is + -- the most significant bit (interpreting the sequence of bits that + -- represent a component as an unsigned integer value). + -- On a low-order first machine, bit zero is the least significant. + -- In this check, a right shift of one place on a Big Endian machine + -- will yield a result of one, while on a Little Endian machine the + -- result would be four. + + TC_Val_Unsigned_8 := 2; + Big_Endian := (Shift_Right(TC_Val_Unsigned_8, 1) = 1); + + + -- Note: The shifting and rotating subprograms operate on a bit-by-bit + -- basis, using the binary representation of the value of the + -- operands to yield a binary representation for the result. + + -- Function Shift_Left. + + if Big_Endian then -- High-order first bit ordering. + + TC_Amount := 1; + TC_Val_Unsigned_8 := Unsigned_8'Last; -- 255. + TC_Result_Unsigned_8 := Shift_Left(Value => TC_Val_Unsigned_8, + Amount => TC_Amount); + if TC_Result_Unsigned_8 /= 254 then + Report.Failed("Incorrect result from BE Shift_Left - 1"); + end if; + + if Shift_Left(TC_Val_Unsigned_8, 2) /= 252 or + Shift_Left(TC_Val_Unsigned_8, 3) /= 248 or + Shift_Left(TC_Val_Unsigned_8, 5) /= 224 or + Shift_Left(TC_Val_Unsigned_8, 8) /= 0 or + Shift_Left(TC_Val_Unsigned_8, 9) /= 0 or + Shift_Left(TC_Val_Unsigned_8, 0) /= TC_Val_Unsigned_8 + then + Report.Failed("Incorrect result from BE Shift_Left - 2"); + end if; + + TC_Val_Unsigned_8 := 1; + if Shift_Left(TC_Val_Unsigned_8, 1) /= 2 or + Shift_Left(TC_Val_Unsigned_8, Amount => 3) /= 8 + then + Report.Failed("Incorrect result from BE Shift_Left - 3"); + end if; + + TC_Val_Unsigned_8 := 7; + if Shift_Left(TC_Val_Unsigned_8, Amount => 4) /= 112 or + Shift_Left(Shift_Left(TC_Val_Unsigned_8, 7), 1) /= 0 + then + Report.Failed("Incorrect result from BE Shift_Left - 4"); + end if; + + else -- Low-order first bit ordering. + + TC_Amount := 1; + TC_Val_Unsigned_8 := Unsigned_8'Last; -- 255. + TC_Result_Unsigned_8 := Shift_Left(TC_Val_Unsigned_8, TC_Amount); + + if TC_Result_Unsigned_8 /= 127 then + Report.Failed("Incorrect result from LE Shift_Left - 1"); + end if; + + if Shift_Left(TC_Val_Unsigned_8, 2) /= 63 or + Shift_Left(TC_Val_Unsigned_8, 3) /= 31 or + Shift_Left(TC_Val_Unsigned_8, 5) /= 7 or + Shift_Left(TC_Val_Unsigned_8, 8) /= 0 or + Shift_Left(TC_Val_Unsigned_8, 0) /= TC_Val_Unsigned_8 + then + Report.Failed("Incorrect result from LE Shift_Left - 2"); + end if; + + TC_Val_Unsigned_8 := 1; + if Shift_Left(TC_Val_Unsigned_8, 1) /= 0 or + Shift_Left(TC_Val_Unsigned_8, 7) /= 0 + then + Report.Failed("Incorrect result from LE Shift_Left - 3"); + end if; + + TC_Val_Unsigned_8 := 129; + if Shift_Left(TC_Val_Unsigned_8, 4) /= 8 or + Shift_Left(Shift_Left(TC_Val_Unsigned_8, 7), 1) /= 0 + then + Report.Failed("Incorrect result from LE Shift_Left - 4"); + end if; + + end if; + + + + -- Function Shift_Right. + + if Big_Endian then -- High-order first bit ordering. + + TC_Amount := 1; + TC_Val_Unsigned_8 := Unsigned_8'Last; -- 255. + TC_Result_Unsigned_8 := Shift_Right(TC_Val_Unsigned_8, TC_Amount); + + if TC_Result_Unsigned_8 /= 127 then + Report.Failed("Incorrect result from BE Shift_Right - 1"); + end if; + + if Shift_Right(TC_Val_Unsigned_8, 2) /= 63 or + Shift_Right(TC_Val_Unsigned_8, 3) /= 31 or + Shift_Right(TC_Val_Unsigned_8, 5) /= 7 or + Shift_Right(TC_Val_Unsigned_8, 8) /= 0 or + Shift_Right(TC_Val_Unsigned_8, 0) /= TC_Val_Unsigned_8 + then + Report.Failed("Incorrect result from BE Shift_Right - 2"); + end if; + + TC_Val_Unsigned_8 := 1; + if Shift_Right(TC_Val_Unsigned_8, 1) /= 0 or + Shift_Right(TC_Val_Unsigned_8, 7) /= 0 + then + Report.Failed("Incorrect result from BE Shift_Right - 3"); + end if; + + TC_Val_Unsigned_8 := 129; + if Shift_Right(TC_Val_Unsigned_8, 4) /= 8 or + Shift_Right(Shift_Right(TC_Val_Unsigned_8, 7), 1) /= 0 + then + Report.Failed("Incorrect result from BE Shift_Right - 4"); + end if; + + else -- Low-order first bit ordering. + + TC_Amount := 1; + TC_Val_Unsigned_8 := Unsigned_8'Last; -- 255. + TC_Result_Unsigned_8 := Shift_Right(Value => TC_Val_Unsigned_8, + Amount => TC_Amount); + if TC_Result_Unsigned_8 /= 254 then + Report.Failed("Incorrect result from LE Shift_Right - 1"); + end if; + + if Shift_Right(TC_Val_Unsigned_8, 2) /= 252 or + Shift_Right(TC_Val_Unsigned_8, 3) /= 248 or + Shift_Right(TC_Val_Unsigned_8, 5) /= 224 or + Shift_Right(TC_Val_Unsigned_8, 8) /= 0 or + Shift_Right(TC_Val_Unsigned_8, 9) /= 0 or + Shift_Right(TC_Val_Unsigned_8, 0) /= TC_Val_Unsigned_8 + then + Report.Failed("Incorrect result from LE Shift_Right - 2"); + end if; + + TC_Val_Unsigned_8 := 1; + if Shift_Right(TC_Val_Unsigned_8, 1) /= 2 or + Shift_Right(TC_Val_Unsigned_8, Amount => 3) /= 8 + then + Report.Failed("Incorrect result from LE Shift_Right - 3"); + end if; + + TC_Val_Unsigned_8 := 7; + if Shift_Right(TC_Val_Unsigned_8, Amount => 4) /= 112 or + Shift_Right(Shift_Right(TC_Val_Unsigned_8, 7), 1) /= 0 + then + Report.Failed("Incorrect result from LE Shift_Right - 4"); + end if; + + end if; + + + + -- Tests of Shift_Left and Shift_Right in combination. + + if Big_Endian then -- High-order first bit ordering. + + TC_Val_Unsigned_8 := 32; + + if Shift_Left(Shift_Right(TC_Val_Unsigned_8, 2), 2) /= + TC_Val_Unsigned_8 or + Shift_Left(Shift_Right(TC_Val_Unsigned_8, 1), 3) /= 128 or + Shift_Right(Shift_Left(TC_Val_Unsigned_8, 2), 6) /= 2 or + Shift_Right(Shift_Left(TC_Val_Unsigned_8, 2), 8) /= 0 + then + Report.Failed("Incorrect result from BE Shift_Left - " & + "Shift_Right functions used in combination"); + end if; + + else -- Low-order first bit ordering. + + TC_Val_Unsigned_8 := 32; + + if Shift_Left(Shift_Right(TC_Val_Unsigned_8, 2), 2) /= + TC_Val_Unsigned_8 or + Shift_Left(Shift_Right(TC_Val_Unsigned_8, 1), 3) /= 8 or + Shift_Right(Shift_Left(TC_Val_Unsigned_8, 2), 3) /= 64 or + Shift_Right(Shift_Left(TC_Val_Unsigned_8, 2), 4) /= 128 + then + Report.Failed("Incorrect result from LE Shift_Left - " & + "Shift_Right functions used in combination"); + end if; + + end if; + + + + -- Function Shift_Right_Arithmetic. + + if Big_Endian then -- High-order first bit ordering. + + -- Case where the parameter Value is less than + -- one half of the modulus. Zero bits will be shifted in. + -- Modulus of type Unsigned_8 is 256; half of the modulus is 128. + + TC_Amount := 1; + TC_Val_Unsigned_8 := 127; -- Less than one half of modulus. + TC_Result_Unsigned_8 := Shift_Right_Arithmetic(TC_Val_Unsigned_8, + TC_Amount); + if TC_Result_Unsigned_8 /= 63 then + Report.Failed + ("Incorrect result from BE Shift_Right_Arithmetic - 1"); + end if; + + if Shift_Right_Arithmetic(TC_Val_Unsigned_8, 2) /= 31 or + Shift_Right_Arithmetic(TC_Val_Unsigned_8, 3) /= 15 or + Shift_Right_Arithmetic(TC_Val_Unsigned_8, 5) /= 3 or + Shift_Right_Arithmetic(TC_Val_Unsigned_8, 8) /= 0 or + Shift_Right_Arithmetic(TC_Val_Unsigned_8, 0) /= TC_Val_Unsigned_8 + then + Report.Failed + ("Incorrect result from BE Shift_Right_Arithmetic - 2"); + end if; + + TC_Val_Unsigned_8 := 1; + if Shift_Right_Arithmetic(TC_Val_Unsigned_8, Amount => 1) /= 0 or + Shift_Right_Arithmetic(TC_Val_Unsigned_8, 3) /= 0 + then + Report.Failed + ("Incorrect result from BE Shift_Right_Arithmetic - 3"); + end if; + + -- Case where the parameter Value is greater than or equal to + -- one half of the modulus. One bits will be shifted in. + + TC_Amount := 1; + TC_Val_Unsigned_8 := 128; -- One half of modulus. + TC_Result_Unsigned_8 := Shift_Right_Arithmetic(TC_Val_Unsigned_8, + Amount => TC_Amount); + if TC_Result_Unsigned_8 /= 192 then + Report.Failed + ("Incorrect result from BE Shift_Right_Arithmetic - 4"); + end if; + + TC_Amount := 1; + TC_Val_Unsigned_8 := 129; -- Greater than one half of modulus. + TC_Result_Unsigned_8 := Shift_Right_Arithmetic(TC_Val_Unsigned_8, + Amount => TC_Amount); + if TC_Result_Unsigned_8 /= 192 then + Report.Failed + ("Incorrect result from BE Shift_Right_Arithmetic - 5"); + end if; + + if Shift_Right_Arithmetic(TC_Val_Unsigned_8, 2) /= 224 or + Shift_Right_Arithmetic(TC_Val_Unsigned_8, 3) /= 240 or + Shift_Right_Arithmetic(TC_Val_Unsigned_8, 5) /= 252 or + Shift_Right_Arithmetic(TC_Val_Unsigned_8, 7) /= Unsigned_8'Last or + Shift_Right_Arithmetic(TC_Val_Unsigned_8, 0) /= TC_Val_Unsigned_8 + then + Report.Failed + ("Incorrect result from BE Shift_Right_Arithmetic - 6"); + end if; + + TC_Val_Unsigned_8 := Unsigned_8'Last; + if Shift_Right_Arithmetic(TC_Val_Unsigned_8, 1) /= + Unsigned_8'Last + then + Report.Failed + ("Incorrect result from BE Shift_Right_Arithmetic - 7"); + end if; + + else -- Low-order first bit ordering + + -- Case where the parameter Value is less than + -- one half of the modulus. Zero bits will be shifted in. + + TC_Amount := 1; + TC_Val_Unsigned_8 := 127; -- Less than one half of modulus. + TC_Result_Unsigned_8 := Shift_Right_Arithmetic(TC_Val_Unsigned_8, + TC_Amount); + if TC_Result_Unsigned_8 /= 254 then + Report.Failed + ("Incorrect result from LE Shift_Right_Arithmetic - 1"); + end if; + + TC_Val_Unsigned_8 := 2; + if Shift_Right_Arithmetic(TC_Val_Unsigned_8, 2) /= 8 or + Shift_Right_Arithmetic(TC_Val_Unsigned_8, 3) /= 16 or + Shift_Right_Arithmetic(TC_Val_Unsigned_8, 5) /= 64 or + Shift_Right_Arithmetic(TC_Val_Unsigned_8, 8) /= 0 or + Shift_Right_Arithmetic(TC_Val_Unsigned_8, 0) /= TC_Val_Unsigned_8 + then + Report.Failed + ("Incorrect result from LE Shift_Right_Arithmetic - 2"); + end if; + + TC_Val_Unsigned_8 := 64; + if Shift_Right_Arithmetic(TC_Val_Unsigned_8, Amount => 1) /= 128 or + Shift_Right_Arithmetic(TC_Val_Unsigned_8, 3) /= 0 + then + Report.Failed + ("Incorrect result from LE Shift_Right_Arithmetic - 3"); + end if; + + -- Case where the parameter Value is greater than or equal to + -- one half of the modulus. One bits will be shifted in. + + TC_Amount := 1; + TC_Val_Unsigned_8 := 128; -- One half of modulus. + TC_Result_Unsigned_8 := Shift_Right_Arithmetic(TC_Val_Unsigned_8, + Amount => TC_Amount); + + if TC_Result_Unsigned_8 /= 3 then + Report.Failed + ("Incorrect result from LE Shift_Right_Arithmetic - 4"); + end if; + + TC_Amount := 1; + TC_Val_Unsigned_8 := 129; -- Greater than one half of modulus. + TC_Result_Unsigned_8 := Shift_Right_Arithmetic(TC_Val_Unsigned_8, + Amount => TC_Amount); + + if TC_Result_Unsigned_8 /= 3 then + Report.Failed + ("Incorrect result from LE Shift_Right_Arithmetic - 5"); + end if; + + TC_Val_Unsigned_8 := 135; -- Greater than one half of modulus. + if Shift_Right_Arithmetic(TC_Val_Unsigned_8, 2) /= 31 or + Shift_Right_Arithmetic(TC_Val_Unsigned_8, 3) /= 63 or + Shift_Right_Arithmetic(TC_Val_Unsigned_8, 5) /= Unsigned_8'Last or + Shift_Right_Arithmetic(TC_Val_Unsigned_8, 7) /= Unsigned_8'Last or + Shift_Right_Arithmetic(TC_Val_Unsigned_8, 0) /= TC_Val_Unsigned_8 + then + Report.Failed + ("Incorrect result from LE Shift_Right_Arithmetic - 6"); + end if; + + TC_Val_Unsigned_8 := Unsigned_8'Last; + if Shift_Right_Arithmetic(TC_Val_Unsigned_8, 1) /= + Unsigned_8'Last + then + Report.Failed + ("Incorrect result from LE Shift_Right_Arithmetic - 7"); + end if; + + end if; + + + + -- Function Rotate_Left. + + if Big_Endian then -- High-order first bit ordering. + + TC_Amount := 1; + TC_Val_Unsigned_8 := 129; + TC_Result_Unsigned_8 := Rotate_Left(Value => TC_Val_Unsigned_8, + Amount => TC_Amount); + if TC_Result_Unsigned_8 /= 3 then + Report.Failed("Incorrect result from BE Rotate_Left - 1"); + end if; + + if Rotate_Left(TC_Val_Unsigned_8, 2) /= 6 or + Rotate_Left(TC_Val_Unsigned_8, 3) /= 12 or + Rotate_Left(TC_Val_Unsigned_8, 5) /= 48 or + Rotate_Left(TC_Val_Unsigned_8, 8) /= 129 or + Rotate_Left(TC_Val_Unsigned_8, 0) /= TC_Val_Unsigned_8 + then + Report.Failed("Incorrect result from BE Rotate_Left - 2"); + end if; + + TC_Val_Unsigned_8 := 1; + if Rotate_Left(Value => TC_Val_Unsigned_8, Amount => 1) /= 2 or + Rotate_Left(TC_Val_Unsigned_8, Amount => 3) /= 8 + then + Report.Failed("Incorrect result from BE Rotate_Left - 3"); + end if; + + TC_Val_Unsigned_8 := 82; + if Rotate_Left(TC_Val_Unsigned_8, Amount => 4) /= 37 or + Rotate_Left(Rotate_Left(TC_Val_Unsigned_8, 7), 1) /= 82 + then + Report.Failed("Incorrect result from BE Rotate_Left - 4"); + end if; + + else -- Low-order first bit ordering. + + TC_Amount := 1; + TC_Val_Unsigned_8 := 1; + TC_Result_Unsigned_8 := Rotate_Left(TC_Val_Unsigned_8, TC_Amount); + + if TC_Result_Unsigned_8 /= 128 then + Report.Failed("Incorrect result from LE Rotate_Left - 1"); + end if; + + TC_Val_Unsigned_8 := 15; + if Rotate_Left(TC_Val_Unsigned_8, 2) /= 195 or + Rotate_Left(TC_Val_Unsigned_8, 3) /= 225 or + Rotate_Left(TC_Val_Unsigned_8, 5) /= 120 or + Rotate_Left(TC_Val_Unsigned_8, 8) /= TC_Val_Unsigned_8 or + Rotate_Left(TC_Val_Unsigned_8, 0) /= TC_Val_Unsigned_8 + then + Report.Failed("Incorrect result from LE Rotate_Left - 2"); + end if; + + TC_Val_Unsigned_8 := Unsigned_8'Last; + if Rotate_Left(TC_Val_Unsigned_8, 1) /= Unsigned_8'Last then + Report.Failed("Incorrect result from LE Rotate_Left - 3"); + end if; + + TC_Val_Unsigned_8 := 12; + if Rotate_Left(TC_Val_Unsigned_8, 1) /= 6 or + Rotate_Left(TC_Val_Unsigned_8, 3) /= 129 + then + Report.Failed("Incorrect result from LE Rotate_Left - 4"); + end if; + + TC_Val_Unsigned_8 := 129; + if Rotate_Left(TC_Val_Unsigned_8, 4) /= 24 or + Rotate_Left(Rotate_Left(TC_Val_Unsigned_8, 7), 1) /= 129 + then + Report.Failed("Incorrect result from LE Rotate_Left - 5"); + end if; + + end if; + + + + -- Function Rotate_Right. + + if Big_Endian then -- High-order first bit ordering. + + TC_Amount := 1; + TC_Val_Unsigned_8 := 1; + TC_Result_Unsigned_8 := Rotate_Right(TC_Val_Unsigned_8, TC_Amount); + + if TC_Result_Unsigned_8 /= 128 then + Report.Failed("Incorrect result from BE Rotate_Right - 1"); + end if; + + TC_Val_Unsigned_8 := 15; + if Rotate_Right(TC_Val_Unsigned_8, 2) /= 195 or + Rotate_Right(TC_Val_Unsigned_8, 3) /= 225 or + Rotate_Right(TC_Val_Unsigned_8, 5) /= 120 or + Rotate_Right(TC_Val_Unsigned_8, 8) /= TC_Val_Unsigned_8 or + Rotate_Right(TC_Val_Unsigned_8, 0) /= TC_Val_Unsigned_8 + then + Report.Failed("Incorrect result from BE Rotate_Right - 2"); + end if; + + TC_Val_Unsigned_8 := Unsigned_8'Last; + if Rotate_Right(TC_Val_Unsigned_8, 1) /= Unsigned_8'Last then + Report.Failed("Incorrect result from BE Rotate_Right - 3"); + end if; + + TC_Val_Unsigned_8 := 12; + if Rotate_Right(TC_Val_Unsigned_8, 1) /= 6 or + Rotate_Right(TC_Val_Unsigned_8, 3) /= 129 + then + Report.Failed("Incorrect result from BE Rotate_Right - 4"); + end if; + + TC_Val_Unsigned_8 := 129; + if Rotate_Right(TC_Val_Unsigned_8, 4) /= 24 or + Rotate_Right(Rotate_Right(TC_Val_Unsigned_8, 7), 1) /= 129 + then + Report.Failed("Incorrect result from BE Rotate_Right - 5"); + end if; + + else -- Low-order first bit ordering. + + TC_Amount := 1; + TC_Val_Unsigned_8 := 129; + TC_Result_Unsigned_8 := Rotate_Right(Value => TC_Val_Unsigned_8, + Amount => TC_Amount); + if TC_Result_Unsigned_8 /= 3 then + Report.Failed("Incorrect result from LE Rotate_Right - 1"); + end if; + + if Rotate_Right(TC_Val_Unsigned_8, 2) /= 6 or + Rotate_Right(TC_Val_Unsigned_8, 3) /= 12 or + Rotate_Right(TC_Val_Unsigned_8, 5) /= 48 or + Rotate_Right(TC_Val_Unsigned_8, 8) /= 129 or + Rotate_Right(TC_Val_Unsigned_8, 0) /= TC_Val_Unsigned_8 + then + Report.Failed("Incorrect result from LE Rotate_Right - 2"); + end if; + + TC_Val_Unsigned_8 := 1; + if Rotate_Right(Value => TC_Val_Unsigned_8, Amount => 1) /= 2 or + Rotate_Right(TC_Val_Unsigned_8, Amount => 3) /= 8 + then + Report.Failed("Incorrect result from LE Rotate_Right - 3"); + end if; + + TC_Val_Unsigned_8 := 82; + if Rotate_Right(TC_Val_Unsigned_8, Amount => 4) /= 37 or + Rotate_Right(Rotate_Right(TC_Val_Unsigned_8, 7), 1) /= 82 + then + Report.Failed("Incorrect result from LE Rotate_Right - 4"); + end if; + + end if; + + + + -- Tests of Rotate_Left and Rotate_Right in combination. + + if Big_Endian then -- High-order first bit ordering. + + TC_Val_Unsigned_8 := 17; + + if Rotate_Left(Rotate_Right(TC_Val_Unsigned_8, 2), 2) /= + TC_Val_Unsigned_8 or + Rotate_Left(Rotate_Right(TC_Val_Unsigned_8, 1), 3) /= 68 or + Rotate_Right(Rotate_Left(TC_Val_Unsigned_8, 3), 7) /= 17 or + Rotate_Right(Rotate_Left(TC_Val_Unsigned_8, 2), 8) /= 68 + then + Report.Failed("Incorrect result from BE Rotate_Left - " & + "Rotate_Right functions used in combination"); + end if; + + else -- Low-order first bit ordering. + + TC_Val_Unsigned_8 := 4; + + if Rotate_Left(Rotate_Right(TC_Val_Unsigned_8, 2), 2) /= + TC_Val_Unsigned_8 or + Rotate_Left(Rotate_Right(TC_Val_Unsigned_8, 1), 3) /= 1 or + Rotate_Right(Rotate_Left(TC_Val_Unsigned_8, 3), 7) /= 64 or + Rotate_Right(Rotate_Left(TC_Val_Unsigned_8, 2), 8) /= 1 + then + Report.Failed("Incorrect result from LE Rotate_Left - " & + "Rotate_Right functions used in combination"); + end if; + + end if; + + exception + when The_Error : others => + Report.Failed ("The following exception was raised in the " & + "Test_Block: " & Exception_Name(The_Error)); + end Test_Block; + + Report.Result; + +end CXB2001; diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb2002.a b/gcc/testsuite/ada/acats/tests/cxb/cxb2002.a new file mode 100644 index 000000000..945722295 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb2002.a @@ -0,0 +1,259 @@ +-- CXB2002.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 subprograms Shift_Left, Shift_Right, +-- Shift_Right_Arithmetic, Rotate_Left, and Rotate_Right are available +-- and produce correct results for values of signed and modular +-- integer types of 16 bits. +-- +-- TEST DESCRIPTION: +-- This test uses the shift and rotate functions of package Interfaces +-- with a modular type representative of 16 bits. The functions +-- are used as the right hand of assignment statements, as part of +-- conditional statements, and as arguments in other function calls. +-- +-- APPLICABILITY CRITERIA: +-- This test is applicable to all implementations that support signed +-- and modular integer types of 16 bits. +-- +-- +-- CHANGE HISTORY: +-- 21 Aug 95 SAIC Initial prerelease version. +-- 07 May 96 SAIC Incorporated reviewer comments for ACVC 2.1. +-- 26 Oct 96 SAIC Removed subtests based on Big/Little Endian. +-- 17 Feb 97 PWB.CTA Corrected "-" to "+" in parenthesized expressions. +--! + +with Report; +with Interfaces; +with Ada.Exceptions; + +procedure CXB2002 is +begin + + Report.Test ("CXB2002", + "Check that subprograms Shift_Left, Shift_Right, " & + "Shift_Right_Arithmetic, Rotate_Left, and Rotate_Right " & + "produce correct results for values of signed and " & + "modular integer types of 16 bits"); + + Test_Block: + declare + + use Ada.Exceptions; + use Interfaces; + + TC_Amount : Natural := Natural'First; + + -- Range of type Unsigned_16 is 0..65535 (0..Modulus-1). + TC_Val_Unsigned_16, + TC_Result_Unsigned_16 : Unsigned_16 := Unsigned_16'First; + + begin + + -- Note: The shifting and rotating subprograms operate on a bit-by-bit + -- basis, using the binary representation of the value of the + -- operands to yield a binary representation for the result. + + -- Function Shift_Left. + + TC_Amount := 3; + TC_Val_Unsigned_16 := Unsigned_16'Last; -- 65535. + TC_Result_Unsigned_16 := Shift_Left(TC_Val_Unsigned_16, TC_Amount); + + if TC_Result_Unsigned_16 /= Unsigned_16'Last - (2**0 + 2**1 + 2**2) + then + Report.Failed("Incorrect result from Shift_Left - 1"); + end if; + + if Shift_Left(TC_Val_Unsigned_16, 0) /= Unsigned_16'Last or + Shift_Left(TC_Val_Unsigned_16, 5) /= + Unsigned_16'Last - (2**0 + 2**1 + 2**2 + 2**3 +2**4) or + Shift_Left(TC_Val_Unsigned_16, 16) /= 0 + then + Report.Failed("Incorrect result from Shift_Left - 2"); + end if; + + + -- Function Shift_Right. + + TC_Amount := 3; + TC_Val_Unsigned_16 := Unsigned_16'Last; -- 65535. + TC_Result_Unsigned_16 := Shift_Right(Value => TC_Val_Unsigned_16, + Amount => TC_Amount); + + if TC_Result_Unsigned_16 /= Unsigned_16'Last-(2**15 + 2**14 + 2**13) + then + Report.Failed("Incorrect result from Shift_Right - 1"); + end if; + + if Shift_Right(TC_Val_Unsigned_16, 0) /= Unsigned_16'Last or + Shift_Right(TC_Val_Unsigned_16, 5) /= + Unsigned_16'Last-(2**15 + 2**14 + 2**13 + 2**12 + 2**11) or + Shift_Right(TC_Val_Unsigned_16, 16) /= 0 + then + Report.Failed("Incorrect result from Shift_Right - 2"); + end if; + + + -- Tests of Shift_Left and Shift_Right in combination. + + TC_Val_Unsigned_16 := Unsigned_16'Last; + + if Shift_Left(Shift_Right(TC_Val_Unsigned_16, 4), 4) /= + Unsigned_16'Last-(2**0 + 2**1 + 2**2 + 2**3) or + Shift_Left(Shift_Right(TC_Val_Unsigned_16, 1), 3) /= + Unsigned_16'Last-(2**0 + 2**1 + 2**2) or + Shift_Right(Shift_Left(TC_Val_Unsigned_16, 2), 4) /= + Unsigned_16'Last-(2**15+ 2**14 + 2**13 + 2**12) or + Shift_Right(Shift_Left(TC_Val_Unsigned_16, 2), 16) /= 0 + then + Report.Failed("Incorrect result from Shift_Left - " & + "Shift_Right functions used in combination"); + end if; + + + -- Function Shift_Right_Arithmetic. + + -- Case where the parameter Value is less than + -- one half of the modulus. Zero bits will be shifted in. + -- Modulus of type Unsigned_16 is 2**16; one half is 2**15. + + TC_Amount := 3; + TC_Val_Unsigned_16 := 2**15 - 1; -- Less than one half of modulus. + TC_Result_Unsigned_16 := Shift_Right_Arithmetic(TC_Val_Unsigned_16, + TC_Amount); + if TC_Result_Unsigned_16 /= + TC_Val_Unsigned_16 - (2**14 + 2**13 + 2**12) + then + Report.Failed + ("Incorrect result from Shift_Right_Arithmetic - 1"); + end if; + + if Shift_Right_Arithmetic(TC_Val_Unsigned_16, 0) /= + TC_Val_Unsigned_16 or + Shift_Right_Arithmetic(TC_Val_Unsigned_16, 5) /= + TC_Val_Unsigned_16 - (2**14 + 2**13 + 2**12 + 2**11 + 2**10) or + Shift_Right_Arithmetic(TC_Val_Unsigned_16, 16) /= 0 + then + Report.Failed + ("Incorrect result from Shift_Right_Arithmetic - 2"); + end if; + + -- Case where the parameter Value is greater than or equal to + -- one half of the modulus. One bits will be shifted in. + + TC_Amount := 1; + TC_Val_Unsigned_16 := 2**15; -- One half of modulus. + TC_Result_Unsigned_16 := Shift_Right_Arithmetic(TC_Val_Unsigned_16, + TC_Amount); + if TC_Result_Unsigned_16 /= TC_Val_Unsigned_16 + 2**14 then + Report.Failed + ("Incorrect result from Shift_Right_Arithmetic - 3"); + end if; + + TC_Amount := 1; + TC_Val_Unsigned_16 := 2**15 + 1; -- Greater than half of modulus. + TC_Result_Unsigned_16 := Shift_Right_Arithmetic(TC_Val_Unsigned_16, + TC_Amount); + if TC_Result_Unsigned_16 /= TC_Val_Unsigned_16 + 2**14 - 2**0 then + Report.Failed + ("Incorrect result from Shift_Right_Arithmetic - 4"); + end if; + + if Shift_Right_Arithmetic(TC_Val_Unsigned_16, 0) /= + TC_Val_Unsigned_16 or + Shift_Right_Arithmetic(TC_Val_Unsigned_16, 4) /= + TC_Val_Unsigned_16 - 2**0 + 2**14 + 2**13 + 2**12 + 2**11 or + Shift_Right_Arithmetic(TC_Val_Unsigned_16, 16) /= Unsigned_16'Last + then + Report.Failed + ("Incorrect result from Shift_Right_Arithmetic - 5"); + end if; + + + -- Function Rotate_Left. + + TC_Amount := 3; + TC_Val_Unsigned_16 := Unsigned_16'Last; -- 65535. + TC_Result_Unsigned_16 := Rotate_Left(Value => TC_Val_Unsigned_16, + Amount => TC_Amount); + if TC_Result_Unsigned_16 /= Unsigned_16'Last then + Report.Failed("Incorrect result from Rotate_Left - 1"); + end if; + + TC_Val_Unsigned_16 := 2**15 + 2**14 + 2**1 + 2**0; + if Rotate_Left(TC_Val_Unsigned_16, 0) /= + 2**15 + 2**14 + 2**1 + 2**0 or + Rotate_Left(TC_Val_Unsigned_16, 5) /= + 2**6 + 2**5 + 2**4 + 2**3 or + Rotate_Left(TC_Val_Unsigned_16, 16) /= TC_Val_Unsigned_16 + then + Report.Failed("Incorrect result from Rotate_Left - 2"); + end if; + + + -- Function Rotate_Right. + + TC_Amount := 1; + TC_Val_Unsigned_16 := 2**1 + 2**0; + TC_Result_Unsigned_16 := Rotate_Right(Value => TC_Val_Unsigned_16, + Amount => TC_Amount); + if TC_Result_Unsigned_16 /= 2**15 + 2**0 then + Report.Failed("Incorrect result from Rotate_Right - 1"); + end if; + + if Rotate_Right(TC_Val_Unsigned_16, 0) /= 2**1 + 2**0 or + Rotate_Right(TC_Val_Unsigned_16, 5) /= 2**12 + 2**11 or + Rotate_Right(TC_Val_Unsigned_16, 16) /= 2**1 + 2**0 + then + Report.Failed("Incorrect result from Rotate_Right - 2"); + end if; + + + -- Tests of Rotate_Left and Rotate_Right in combination. + + TC_Val_Unsigned_16 := 32769; + + if Rotate_Left(Rotate_Right(TC_Val_Unsigned_16, 4), 3) /= 49152 or + Rotate_Left(Rotate_Right(TC_Val_Unsigned_16, 1), 3) /= 6 or + Rotate_Right(Rotate_Left(TC_Val_Unsigned_16, 3), 7) /= 6144 or + Rotate_Right(Rotate_Left(TC_Val_Unsigned_16, 1), 16) /= 3 + then + Report.Failed("Incorrect result from Rotate_Left - " & + "Rotate_Right functions used in combination"); + end if; + + + exception + when The_Error : others => + Report.Failed ("The following exception was raised in the " & + "Test_Block: " & Exception_Name(The_Error)); + end Test_Block; + + Report.Result; + +end CXB2002; diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb2003.a b/gcc/testsuite/ada/acats/tests/cxb/cxb2003.a new file mode 100644 index 000000000..ec3998ad8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb2003.a @@ -0,0 +1,255 @@ +-- CXB2003.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 subprograms Shift_Left, Shift_Right, +-- Shift_Right_Arithmetic, Rotate_Left, and Rotate_Right are available +-- and produce correct results for values of signed and modular +-- integer types of 32 bits. +-- +-- TEST DESCRIPTION: +-- This test uses the shift and rotate functions of package Interfaces +-- with a modular type representative of 32 bits. The functions +-- are used as the right hand of assignment statements, as part of +-- conditional statements, and as arguments in other function calls. +-- +-- APPLICABILITY CRITERIA: +-- This test is applicable to all implementations that support signed +-- and modular integer types of 32 bits. +-- +-- +-- CHANGE HISTORY: +-- 23 Aug 95 SAIC Initial prerelease version. +-- 07 May 96 SAIC Incorporated reviewer comments for ACVC 2.1. +-- 26 Oct 96 SAIC Removed all references to Big/Little endian. +-- +--! + +with Report; +with Interfaces; +with Ada.Exceptions; + +procedure CXB2003 is +begin + + Report.Test ("CXB2003", + "Check that subprograms Shift_Left, Shift_Right, " & + "Shift_Right_Arithmetic, Rotate_Left, and Rotate_Right " & + "are available and produce correct results"); + + Test_Block: + declare + + use Interfaces; + use Ada.Exceptions; + + TC_Amount : Natural := Natural'First; + + -- Range of type Unsigned_32 is 0..(2**32)-1 (0..Modulus-1). + TC_Val_Unsigned_32, + TC_Result_Unsigned_32 : Unsigned_32 := Unsigned_32'First; + + begin + + -- Note: The shifting and rotating subprograms operate on a bit-by-bit + -- basis, using the binary representation of the value of the + -- operands to yield a binary representation for the result. + + + -- Function Shift_Left. + + TC_Amount := 2; + TC_Val_Unsigned_32 := Unsigned_32'Last; + TC_Result_Unsigned_32 := Shift_Left(TC_Val_Unsigned_32, TC_Amount); + + if TC_Result_Unsigned_32 /= Unsigned_32'Last - (2**0 + 2**1) then + Report.Failed("Incorrect result from Shift_Left - 1"); + end if; + + TC_Result_Unsigned_32 := Unsigned_32'Last - (2**0 + 2**1 + 2**2 + + 2**3 + 2**4); + if Shift_Left(TC_Val_Unsigned_32, 5) /= TC_Result_Unsigned_32 or + Shift_Left(TC_Val_Unsigned_32, 0) /= Unsigned_32'Last + then + Report.Failed("Incorrect result from Shift_Left - 2"); + end if; + + + -- Function Shift_Right. + + TC_Amount := 3; + TC_Val_Unsigned_32 := Unsigned_32'Last; + TC_Result_Unsigned_32 := Shift_Right(Value => TC_Val_Unsigned_32, + Amount => TC_Amount); + if TC_Result_Unsigned_32 /= + Unsigned_32'Last - (2**31 + 2**30 + 2**29) + then + Report.Failed("Incorrect result from Shift_Right - 1"); + end if; + + if Shift_Right(TC_Val_Unsigned_32, 0) /= Unsigned_32'Last or + Shift_Right(TC_Val_Unsigned_32, 2) /= Unsigned_32'Last - + (2**31 + 2**30) + then + Report.Failed("Incorrect result from Shift_Right - 2"); + end if; + + + -- Tests of Shift_Left and Shift_Right in combination. + + TC_Val_Unsigned_32 := Unsigned_32'Last; + + if Shift_Left(Shift_Right(TC_Val_Unsigned_32, 4), 4) /= + Unsigned_32'Last - (2**0 + 2**1 + 2**2 + 2**3) or + Shift_Left(Shift_Right(TC_Val_Unsigned_32, 3), 1) /= + Unsigned_32'Last - (2**31 + 2**30 + 2**0) or + Shift_Left(Shift_Right(TC_Val_Unsigned_32, 5), 3) /= + Unsigned_32'Last - (2**31 + 2**30 + 2**2 + 2**1 + 2**0) or + Shift_Right(Shift_Left(TC_Val_Unsigned_32, 2), 1) /= + Unsigned_32'Last - (2**31 + 2**0) + then + Report.Failed("Incorrect result from Shift_Left - " & + "Shift_Right functions used in combination"); + end if; + + + -- Function Shift_Right_Arithmetic. + + -- Case where the parameter Value is less than + -- one half of the modulus. Zero bits will be shifted in. + + TC_Amount := 3; + TC_Val_Unsigned_32 := 2**15 + 2**10 + 2**1; + TC_Result_Unsigned_32 := Shift_Right_Arithmetic(TC_Val_Unsigned_32, + TC_Amount); + if TC_Result_Unsigned_32 /= (2**12 + 2**7) then + Report.Failed + ("Incorrect result from Shift_Right_Arithmetic - 1"); + end if; + + if Shift_Right_Arithmetic(TC_Val_Unsigned_32, 0) /= + TC_Val_Unsigned_32 or + Shift_Right_Arithmetic(TC_Val_Unsigned_32, 5) /= + (2**10 + 2**5) + then + Report.Failed + ("Incorrect result from Shift_Right_Arithmetic - 2"); + end if; + + -- Case where the parameter Value is greater than or equal to + -- one half of the modulus. One bits will be shifted in. + + TC_Amount := 1; + TC_Val_Unsigned_32 := 2**31; -- One half of modulus + TC_Result_Unsigned_32 := Shift_Right_Arithmetic(TC_Val_Unsigned_32, + TC_Amount); + if TC_Result_Unsigned_32 /= (2**31 + 2**30) then + Report.Failed + ("Incorrect result from Shift_Right_Arithmetic - 3"); + end if; + + TC_Amount := 1; + TC_Val_Unsigned_32 := (2**31 + 2**1); + TC_Result_Unsigned_32 := Shift_Right_Arithmetic(TC_Val_Unsigned_32, + TC_Amount); + if TC_Result_Unsigned_32 /= (2**31 + 2**30 + 2**0) then + Report.Failed + ("Incorrect result from Shift_Right_Arithmetic - 4"); + end if; + + if Shift_Right_Arithmetic(TC_Val_Unsigned_32, 0) /= + TC_Val_Unsigned_32 or + Shift_Right_Arithmetic(TC_Val_Unsigned_32, 3) /= + (2**31 + 2**30 + 2**29 + 2**28) + then + Report.Failed + ("Incorrect result from Shift_Right_Arithmetic - 5"); + end if; + + + -- Function Rotate_Left. + + TC_Amount := 3; + TC_Val_Unsigned_32 := Unsigned_32'Last; + TC_Result_Unsigned_32 := Rotate_Left(Value => TC_Val_Unsigned_32, + Amount => TC_Amount); + if TC_Result_Unsigned_32 /= Unsigned_32'Last then + Report.Failed("Incorrect result from Rotate_Left - 1"); + end if; + + TC_Val_Unsigned_32 := 2**31 + 2**30; + if Rotate_Left(TC_Val_Unsigned_32, 1) /= (2**31 + 2**0) or + Rotate_Left(TC_Val_Unsigned_32, 5) /= (2**4 + 2**3) or + Rotate_Left(TC_Val_Unsigned_32, 32) /= TC_Val_Unsigned_32 + then + Report.Failed("Incorrect result from Rotate_Left - 2"); + end if; + + + -- Function Rotate_Right. + + TC_Amount := 2; + TC_Val_Unsigned_32 := (2**1 + 2**0); + TC_Result_Unsigned_32 := Rotate_Right(Value => TC_Val_Unsigned_32, + Amount => TC_Amount); + if TC_Result_Unsigned_32 /= (2**31 + 2**30) then + Report.Failed("Incorrect result from Rotate_Right - 1"); + end if; + + if Rotate_Right(TC_Val_Unsigned_32, 3) /= (2**30 + 2**29) or + Rotate_Right(TC_Val_Unsigned_32, 6) /= (2**27 + 2**26) or + Rotate_Right(TC_Val_Unsigned_32, 32) /= (2**1 + 2**0) + then + Report.Failed("Incorrect result from Rotate_Right - 2"); + end if; + + + -- Tests of Rotate_Left and Rotate_Right in combination. + + TC_Val_Unsigned_32 := (2**31 + 2**15 + 2**3); + + if Rotate_Left(Rotate_Right(TC_Val_Unsigned_32, 4), 3) /= + (2**30 + 2**14 + 2**2) or + Rotate_Left(Rotate_Right(TC_Val_Unsigned_32, 1), 3) /= + (2**17 + 2**5 + 2**1) or + Rotate_Right(Rotate_Left(TC_Val_Unsigned_32, 3), 7) /= + (2**31 + 2**27 + 2**11) or + Rotate_Right(Rotate_Left(TC_Val_Unsigned_32, 1), 32) /= + (2**16 + 2**4 + 2**0) + then + Report.Failed("Incorrect result from Rotate_Left - " & + "Rotate_Right functions used in combination"); + end if; + + + exception + when The_Error : others => + Report.Failed ("The following exception was raised in the " & + "Test_Block: " & Exception_Name(The_Error)); + end Test_Block; + + Report.Result; + +end CXB2003; diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb3001.a b/gcc/testsuite/ada/acats/tests/cxb/cxb3001.a new file mode 100644 index 000000000..4d79b24e1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb3001.a @@ -0,0 +1,179 @@ +-- CXB3001.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 the specifications of the package Interfaces.C are +-- available for use. +-- +-- TEST DESCRIPTION: +-- This test verifies that the types and subprograms specified for the +-- interface are present. It just checks for the presence of +-- the subprograms. Other tests are designed to exercise the interface. +-- +-- APPLICABILITY CRITERIA: +-- If an implementation provides package Interfaces.C, this test +-- must compile, execute, and report "PASSED". +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 15 Nov 95 SAIC Corrected To_C parameter list for ACVC 2.0.1. +-- 28 Feb 96 SAIC Added applicability criteria. +-- +--! + +with Report; +with Interfaces.C; -- N/A => ERROR + +procedure CXB3001 is + package C renames Interfaces.C; + use type C.signed_char; + use type C.unsigned_char; + use type C.char; + +begin + + Report.Test ("CXB3001", "Check the specification of Interfaces.C"); + + declare -- encapsulate the test + + + tst_CHAR_BIT : constant := C.CHAR_BIT; + tst_SCHAR_MIN : constant := C.SCHAR_MIN; + tst_SCHAR_MAX : constant := C.SCHAR_MAX; + tst_UCHAR_MAX : constant := C.UCHAR_MAX; + + -- Signed and Unsigned Integers + + tst_int : C.int := C.int'first; + tst_short : C.short := C.short'first; + tst_long : C.long := C.long'first; + + tst_signed_char_min : C.signed_char := C.signed_char'first; + tst_signed_char_max : C.signed_char := C.signed_char'last; + + tst_unsigned : C.unsigned; + tst_unsigned_short : C.unsigned_short; + tst_unsigned_long : C.unsigned_long; + + tst_unsigned_char : C.unsigned_char; + tst_plain_char : C.plain_char; + + tst_ptrdiff_t : C.ptrdiff_t; + tst_size_t : C.size_t; + + -- Floating-Point + + tst_C_float : C.C_float; + tst_double : C.double; + tst_long_double : C.long_double; + + -- Characters and Strings + + tst_char : C.char; + tst_nul : C.char := C.nul; + + -- Collect all the subprogram calls such that they are compiled + -- but not executed + -- + procedure Collect_All_Calls is + + CAC_char : C.char; + CAC_Character : Character; + CAC_String : string (1..5); + CAC_Boolean : Boolean := false; + CAC_char_array : C.char_array(1..5); + CAC_Integer : integer; + CAC_Natural : natural; + CAC_wchar_t : C.wchar_t; + CAC_Wide_Character : Wide_Character; + CAC_wchar_array : C.wchar_array(1..5); + CAC_Wide_String : Wide_String(1..5); + CAC_size_t : C.size_t; + + begin + + CAC_char := C.To_C (CAC_Character); + CAC_Character := C.To_Ada (CAC_char); + + CAC_char_array := C.To_C (CAC_String, CAC_Boolean); + CAC_String := C.To_Ada (CAC_char_array, CAC_Boolean); + + -- This call is out of LRM order so that we can use the + -- array initialized above + CAC_Boolean := C.Is_Nul_Terminated (CAC_char_array); + + C.To_C (CAC_String, CAC_char_array, CAC_size_t, CAC_Boolean); + C.To_Ada (CAC_char_array, CAC_String, CAC_Natural, CAC_Boolean); + + CAC_wchar_t := C.To_C (CAC_Wide_Character); + CAC_Wide_Character := C.To_Ada (CAC_wchar_t); + CAC_wchar_t := C.wide_nul; + + CAC_wchar_array := C.To_C (CAC_Wide_String, CAC_Boolean); + CAC_Wide_String := C.To_Ada (CAC_wchar_array, CAC_Boolean); + + -- This call is out of LRM order so that we can use the + -- array initialized above + CAC_Boolean := C.Is_Nul_Terminated (CAC_wchar_array); + + C.To_C (CAC_Wide_String, CAC_wchar_array, CAC_size_t, CAC_Boolean); + C.To_Ada (CAC_wchar_array, CAC_Wide_String, CAC_Natural, CAC_Boolean); + + raise C.Terminator_Error; + + end Collect_All_Calls; + + + + begin -- encapsulation + + if tst_signed_char_min /= C.SCHAR_MIN then + Report.Failed ("tst_signed_char_min is incorrect"); + end if; + if tst_signed_char_max /= C.SCHAR_MAX then + Report.Failed ("tst_signed_char_max is incorrect"); + end if; + if C.signed_char'Size /= C.CHAR_BIT then + Report.Failed ("C.signed_char'Size is incorrect"); + end if; + + if C.unsigned_char'first /= 0 or + C.unsigned_char'last /= C.UCHAR_MAX or + C.unsigned_char'size /= C.CHAR_BIT then + + Report.Failed ("unsigned_char is incorrectly defined"); + + end if; + + if tst_nul /= C.char'first then + Report.Failed ("tst_nul is incorrect"); + end if; + + end; -- encapsulation + + Report.Result; + +end CXB3001; diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb3002.a b/gcc/testsuite/ada/acats/tests/cxb/cxb3002.a new file mode 100644 index 000000000..b543d467c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb3002.a @@ -0,0 +1,158 @@ +-- CXB3002.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 the specifications of the package Interfaces.C.Strings +-- are available for use. +-- +-- TEST DESCRIPTION: +-- This test verifies that the types and subprograms specified for the +-- interface are present +-- +-- APPLICABILITY CRITERIA: +-- If an implementation provides packages Interfaces.C and +-- Interfaces.C.Strings, this test must compile, execute, and +-- report "PASSED". +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 28 Feb 96 SAIC Added applicability criteria. +-- +--! + +with Report; +with Interfaces.C; -- N/A => ERROR +with Interfaces.C.Strings; -- N/A => ERROR + +procedure CXB3002 is + package Strings renames Interfaces.C.Strings; + package C renames Interfaces.C; + +begin + + Report.Test ("CXB3002", "Check the specification of Interfaces.C.Strings"); + + + declare -- encapsulate the test + + TC_Int_1 : integer := 1; + TC_Int_2 : integer := 1; + TC_String : String := "ABCD"; + TC_Boolean : Boolean := true; + TC_char_array : C.char_array (1..5); + TC_size_t : C.size_t := C.size_t'first; + + + -- Note In all of the following the Strings spec. being tested + -- is shown in comment lines + -- + -- type char_array_access is access all char_array; + TST_char_array_access : Strings.char_array_access := + new Interfaces.C.char_array (1..5); + + -- type chars_ptr is private; + -- Null_Ptr : constant chars_ptr; + TST_chars_ptr : Strings.chars_ptr := Strings.Null_ptr; + + -- type chars_ptr_array is array (size_t range <>) of chars_ptr; + TST_chars_ptr_array : Strings.chars_ptr_array(1..5); + + begin -- encapsulation + + -- Arrange that the calls to the subprograms are compiled but + -- not executed + -- + if not Report.Equal ( TC_Int_1, TC_Int_2 ) then + + -- function To_Chars_Ptr (Item : in char_array_access; + -- Nul_Check : in Boolean := False) + -- return chars_ptr; + TST_chars_ptr := Strings.To_Chars_Ptr + (TST_char_array_access, TC_Boolean); + + -- This one is out of LRM order so that we can "initialize" + -- TC_char_array for the "in" parameter of the next one + -- + -- function Value (Item : in chars_ptr) return char_array; + TC_char_array := Strings.Value (TST_chars_ptr); + + -- function New_Char_Array (Chars : in char_array) + -- return chars_ptr; + TST_chars_ptr := Strings.New_Char_Array (TC_char_array); + + -- function New_String (Str : in String) return chars_ptr; + TST_chars_ptr := Strings.New_String ("TEST STRING"); + + -- procedure Free (Item : in out chars_ptr); + Strings.Free (TST_chars_ptr); + + -- function Value (Item : in chars_ptr; Length : in size_t) + -- return char_array; + TC_char_array := Strings.Value (TST_chars_ptr, TC_size_t); + + -- Use Report.Comment as a known procedure which takes a string as + -- a parameter (this does not actually get output) + -- function Value (Item : in chars_ptr) return String; + Report.Comment ( Strings.Value (TST_chars_ptr) ); + + -- function Value (Item : in chars_ptr; Length : in size_t) + -- return String; + TC_String := Strings.Value (TST_chars_ptr, TC_size_t); + + -- function Strlen (Item : in chars_ptr) return size_t; + TC_size_t := Strings.Strlen (TST_chars_ptr); + + -- procedure Update (Item : in chars_ptr; + -- Offset : in size_t; + -- Chars : in char_array; + -- Check : in Boolean := True); + Strings.Update (TST_chars_ptr, TC_size_t, TC_char_array, TC_Boolean); + + -- procedure Update (Item : in chars_ptr; + -- Offset : in size_t; + -- Str : in String; + -- Check : in Boolean := True); + Strings.Update (TST_chars_ptr, TC_size_t, TC_String, TC_Boolean); + + -- Update_Error : exception; + raise Strings.Update_Error; + + end if; + + if not Report.Equal ( TC_Int_2, TC_Int_1 ) then + + -- This exception is out of LRM presentation order to avoid + -- compiler warnings about unreachable code + -- Dereference_Error : exception; + raise Strings.Dereference_Error; + + end if; + + end; -- encapsulation + + Report.Result; + +end CXB3002; diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb3003.a b/gcc/testsuite/ada/acats/tests/cxb/cxb3003.a new file mode 100644 index 000000000..c39583748 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb3003.a @@ -0,0 +1,167 @@ +-- CXB3003.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 the specifications of the package Interfaces.C.Pointers +-- are available for use. +-- +-- TEST DESCRIPTION: +-- This test verifies that the types and subprograms specified for the +-- interface are present +-- +-- APPLICABILITY CRITERIA: +-- If an implementation provides package Interfaces.C.Pointers, this +-- test must compile, execute, and report "PASSED". +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 28 Feb 96 SAIC Added applicability criteria. +-- +--! + +with Report; +with Interfaces.C.Pointers; -- N/A => ERROR + +procedure CXB3003 is + package C renames Interfaces.C; + + package Test_Ptrs is new C.Pointers + (Index => C.size_t, + Element => C.Char, + Element_Array => C.Char_Array, + Default_Terminator => C.Nul); + +begin + + Report.Test ("CXB3003", "Check the specification of Interfaces.C.Pointers"); + + + declare -- encapsulate the test + + TC_Int : integer := 1; + + -- Note: In all of the following the Pointers spec. being tested + -- is shown in comments + -- + -- type Pointer is access all Element; + subtype TST_Pointer_Type is Test_Ptrs.Pointer; + + TST_Element : C.Char := C.Char'First; + TST_Pointer : TST_Pointer_Type := null; + TST_Pointer_2 : TST_Pointer_Type := null; + TST_Array : C.char_array (1..5); + TST_Index : C.ptrdiff_t := C.ptrdiff_t'First; + + begin -- encapsulation + + -- Arrange that the calls to the subprograms are compiled but + -- not executed + -- + if not Report.Equal ( TC_Int, TC_Int ) then + + + -- function Value (Ref : in Pointer; + -- Terminator : in Element := Default_Terminator) + -- return Element_Array; + + TST_Array := Test_Ptrs.Value ( TST_Pointer ); -- default + TST_Array := Test_Ptrs.Value ( TST_Pointer, TST_Element ); + + -- function Value (Ref : in Pointer; Length : in ptrdiff_t) + -- return Element_Array; + + TST_Array := Test_Ptrs.Value (TST_Pointer, TST_Index); + + -- + -- -- C-style Pointer arithmetic + -- + -- function "+" (Left : in Pointer; Right : in ptrdiff_t) + -- return Pointer; + TST_Pointer := Test_Ptrs."+" (TST_Pointer, TST_Index); + + -- function "+" (Left : in Ptrdiff_T; Right : in Pointer) + -- return Pointer; + TST_Pointer := Test_Ptrs."+" (TST_Index, TST_Pointer); + + -- function "-" (Left : in Pointer; Right : in ptrdiff_t) + -- return Pointer; + TST_Pointer := Test_Ptrs."-" (TST_Pointer, TST_Index); + + -- function "-" (Left : in Pointer; Right : in Pointer) + -- return ptrdiff_t; + TST_Index := Test_Ptrs."-" (TST_Pointer, TST_Pointer); + + -- procedure Increment (Ref : in out Pointer); + Test_Ptrs.Increment (TST_Pointer); + + -- procedure Decrement (Ref : in out Pointer); + Test_Ptrs.Decrement (TST_Pointer); + + -- function Virtual_Length + -- ( Ref : in Pointer; + -- Terminator : in Element := Default_Terminator) + -- return ptrdiff_t; + TST_Index := Test_Ptrs.Virtual_Length (TST_Pointer); + TST_Index := Test_Ptrs.Virtual_Length (TST_Pointer, TST_Element); + + -- procedure Copy_Terminated_Array + -- (Source : in Pointer; + -- Target : in Pointer; + -- Limit : in ptrdiff_t := ptrdiff_t'Last; + -- Terminator : in Element := Default_Terminator); + + Test_Ptrs.Copy_Terminated_Array (TST_Pointer, TST_Pointer_2); + + Test_Ptrs.Copy_Terminated_Array (TST_Pointer, + TST_Pointer_2, + TST_Index); + + Test_Ptrs.Copy_Terminated_Array (TST_Pointer, + TST_Pointer_2, + TST_Index, + TST_Element); + + + -- procedure Copy_Array + -- (Source : in Pointer; + -- Target : in Pointer; + -- Length : in ptrdiff_t); + + Test_Ptrs.Copy_Array (TST_Pointer, TST_Pointer_2, TST_Index); + + -- This is out of LRM order to avoid complaints from compilers + -- about inaccessible code + -- Pointer_Error : exception; + + raise Test_Ptrs.Pointer_Error; + + end if; + + end; -- encapsulation + + Report.Result; + +end CXB3003; diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb30040.c b/gcc/testsuite/ada/acats/tests/cxb/cxb30040.c new file mode 100644 index 000000000..1e96e4a57 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb30040.c @@ -0,0 +1,172 @@ +/* +-- CXB30040.C +-- +-- 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. +--* +-- +-- FUNCTION NAME: CXB30040 ("char_gen") +-- +-- FUNCTION DESCRIPTION: +-- This C function returns the value of type char corresponding to the +-- value of its parameter, where +-- Val 0 .. 9 ==> '0' .. '9' +-- Val 10 .. 19 ==> 'A' .. 'J' +-- Val 20 .. 29 ==> 'k' .. 't' +-- Val 30 ==> ' ' +-- Val 31 ==> '.' +-- Val 32 ==> ',' +-- +-- INPUT: +-- This function requires that one int parameter be passed to it. +-- +-- OUTPUT: +-- The function will return the appropriate value of type char. +-- +-- CHANGE HISTORY: +-- 13 Sep 99 RLB Created function to replace incorrect +-- Unchecked_Conversion. +-- +--! +*/ + +char CXB30040 (int val) + +/* NOTE: The above function definition should be accepted by an ANSI-C */ +/* compiler. Older C compilers may reject it; they may, however */ +/* accept the following two lines. An implementation may comment */ +/* out the above function definition and uncomment the following */ +/* one. Otherwise, an implementation must provide the necessary */ +/* modifications to this C code to satisfy the function */ +/* requirements (see Function Description). */ +/* */ +/* char CXB30040 (val) */ +/* int val; */ +/* */ + +{ char return_value = ';'; + + switch (val) + { + case 0: + return_value = '0'; + break; + case 1: + return_value = '1'; + break; + case 2: + return_value = '2'; + break; + case 3: + return_value = '3'; + break; + case 4: + return_value = '4'; + break; + case 5: + return_value = '5'; + break; + case 6: + return_value = '6'; + break; + case 7: + return_value = '7'; + break; + case 8: + return_value = '8'; + break; + case 9: + return_value = '9'; + break; + case 10: + return_value = 'A'; + break; + case 11: + return_value = 'B'; + break; + case 12: + return_value = 'C'; + break; + case 13: + return_value = 'D'; + break; + case 14: + return_value = 'E'; + break; + case 15: + return_value = 'F'; + break; + case 16: + return_value = 'G'; + break; + case 17: + return_value = 'H'; + break; + case 18: + return_value = 'I'; + break; + case 19: + return_value = 'J'; + break; + case 20: + return_value = 'k'; + break; + case 21: + return_value = 'l'; + break; + case 22: + return_value = 'm'; + break; + case 23: + return_value = 'n'; + break; + case 24: + return_value = 'o'; + break; + case 25: + return_value = 'p'; + break; + case 26: + return_value = 'q'; + break; + case 27: + return_value = 'r'; + break; + case 28: + return_value = 's'; + break; + case 29: + return_value = 't'; + break; + case 30: + return_value = ' '; + break; + case 31: + return_value = '.'; + break; + case 32: + return_value = ','; + break; + } + + return (return_value); /* Return character value */ +} diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb30041.am b/gcc/testsuite/ada/acats/tests/cxb/cxb30041.am new file mode 100644 index 000000000..73b874e1f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb30041.am @@ -0,0 +1,377 @@ +-- CXB30041.AM +-- +-- 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 the functions To_C and To_Ada map between the Ada type +-- Character and the C type char. +-- +-- Check that the function Is_Nul_Terminated returns True if the +-- char_array parameter contains nul, and otherwise False. +-- +-- Check that the function To_C produces a correct char_array result, +-- with lower bound of 0, and length dependent upon the Item and +-- Append_Nul parameters. +-- +-- Check that the function To_Ada produces a correct string result, with +-- lower bound of 1, and length dependent upon the Item and Trim_Nul +-- parameters. +-- +-- Check that the function To_Ada raises Terminator_Error if the +-- parameter Trim_Nul is set to True, but the actual Item parameter +-- does not contain the nul char. +-- +-- TEST DESCRIPTION: +-- This test uses a variety of Character, char, String, and char_array +-- objects to test versions of the To_C, To_Ada, and Is_Nul_Terminated +-- functions. +-- +-- This test assumes that the following characters are all included +-- in the implementation defined type Interfaces.C.char: +-- ' ', ',', '.', '0'..'9', 'a'..'z' and 'A'..'Z'. +-- +-- APPLICABILITY CRITERIA: +-- This test is applicable to all implementations that provide +-- package Interfaces.C. If an implementation provides +-- package Interfaces.C, this test must compile, execute, and +-- report "PASSED". +-- +-- SPECIAL REQUIREMENTS: +-- The file CXB30040.C must be compiled with a C compiler. +-- Implementation dialects of C may require alteration of +-- the C program syntax (see individual C files). +-- +-- Note that the compiled C code must be bound with the compiled Ada +-- code to create an executable image. An implementation must provide +-- the necessary commands to accomplish this. +-- +-- Note that the C code included in CXB30040.C conforms +-- to ANSI-C. Modifications to these files may be required for other +-- C compilers. An implementation must provide the necessary +-- modifications to satisfy the function requirements. +-- +-- TEST FILES: +-- The following files comprise this test: +-- +-- CXB30040.C +-- CXB30041.AM +-- +-- CHANGE HISTORY: +-- 30 Aug 95 SAIC Initial prerelease version. +-- 09 May 96 SAIC Incorporated reviewer comments for ACVC 2.1. +-- 26 Oct 96 SAIC Incorporated reviewer comments. +-- 13 Sep 99 RLB Replaced (bogus) Unchecked_Conversions with a +-- C function character generator. +-- +--! + +with Report; +with Interfaces.C; -- N/A => ERROR +with Ada.Characters.Latin_1; +with Ada.Exceptions; +with Ada.Strings.Fixed; +with Impdef; + +procedure CXB30041 is +begin + + Report.Test ("CXB3004", "Check that the functions To_C and To_Ada " & + "produce correct results"); + + Test_Block: + declare + + use Interfaces, Interfaces.C; + use Ada.Characters, Ada.Characters.Latin_1; + use Ada.Exceptions; + use Ada.Strings.Fixed; + + Start_Character, + Stop_Character, + TC_Character : Character := Character'First; + TC_char, + TC_Low_char, + TC_High_char : char := char'First; + TC_String : String(1..8) := (others => Latin_1.NUL); + TC_char_array : char_array(0..7) := (others => C.nul); + + -- The function Char_Gen returns a character corresponding to its + -- argument. + -- Value 0 .. 9 ==> '0' .. '9' + -- Value 10 .. 19 ==> 'A' .. 'J' + -- Value 20 .. 29 ==> 'k' .. 't' + -- Value 30 ==> ' ' + -- Value 31 ==> '.' + -- Value 32 ==> ',' + + function Char_Gen (Value : in int) return char; + + -- Use the user-defined C function char_gen as a completion to the + -- function specification above. + + pragma Import (Convention => C, + Entity => Char_Gen, + External_Name => Impdef.CXB30040_External_Name); + + begin + + -- Check that the functions To_C and To_Ada map between the Ada type + -- Character and the C type char. + + if To_C(Ada.Characters.Latin_1.NUL) /= Interfaces.C.nul then + Report.Failed("Incorrect result from To_C with NUL character input"); + end if; + + Start_Character := Report.Ident_Char('k'); + Stop_Character := Report.Ident_Char('t'); + for TC_Character in Start_Character..Stop_Character loop + if To_C(Item => TC_Character) /= + Char_Gen(Character'Pos(TC_Character) - Character'Pos('k') + 20) then + Report.Failed("Incorrect result from To_C with lower case " & + "alphabetic character input"); + end if; + end loop; + + Start_Character := Report.Ident_Char('A'); + Stop_Character := Report.Ident_Char('J'); + for TC_Character in Start_Character..Stop_Character loop + if To_C(Item => TC_Character) /= + Char_Gen(Character'Pos(TC_Character) - Character'Pos('A') + 10) then + Report.Failed("Incorrect result from To_C with upper case " & + "alphabetic character input"); + end if; + end loop; + + Start_Character := Report.Ident_Char('0'); + Stop_Character := Report.Ident_Char('9'); + for TC_Character in Start_Character..Stop_Character loop + if To_C(Item => TC_Character) /= + Char_Gen(Character'Pos(TC_Character) - Character'Pos('0')) then + Report.Failed("Incorrect result from To_C with digit " & + "character input"); + end if; + end loop; + if To_C(Item => ' ') /= Char_Gen(30) then + Report.Failed("Incorrect result from To_C with space " & + "character input"); + end if; + if To_C(Item => '.') /= Char_Gen(31) then + Report.Failed("Incorrect result from To_C with dot " & + "character input"); + end if; + if To_C(Item => ',') /= Char_Gen(32) then + Report.Failed("Incorrect result from To_C with comma " & + "character input"); + end if; + + if To_Ada(Interfaces.C.nul) /= Ada.Characters.Latin_1.NUL then + Report.Failed("Incorrect result from To_Ada with nul char input"); + end if; + + for Code in int range + int(Report.Ident_Int(20)) .. int(Report.Ident_Int(29)) loop + -- 'k' .. 't' + if To_Ada(Item => Char_Gen(Code)) /= + Character'Val (Character'Pos('k') + (Code - 20)) then + Report.Failed("Incorrect result from To_Ada with lower case " & + "alphabetic char input"); + end if; + end loop; + + for Code in int range + int(Report.Ident_Int(10)) .. int(Report.Ident_Int(19)) loop + -- 'A' .. 'J' + if To_Ada(Item => Char_Gen(Code)) /= + Character'Val (Character'Pos('A') + (Code - 10)) then + Report.Failed("Incorrect result from To_Ada with upper case " & + "alphabetic char input"); + end if; + end loop; + + for Code in int range + int(Report.Ident_Int(0)) .. int(Report.Ident_Int(9)) loop + -- '0' .. '9' + if To_Ada(Item => Char_Gen(Code)) /= + Character'Val (Character'Pos('0') + (Code)) then + Report.Failed("Incorrect result from To_Ada with digit " & + "char input"); + end if; + end loop; + + if To_Ada(Item => Char_Gen(30)) /= ' ' then + Report.Failed("Incorrect result from To_Ada with space " & + "char input"); + end if; + if To_Ada(Item => Char_Gen(31)) /= '.' then + Report.Failed("Incorrect result from To_Ada with dot " & + "char input"); + end if; + if To_Ada(Item => Char_Gen(32)) /= ',' then + Report.Failed("Incorrect result from To_Ada with comma " & + "char input"); + end if; + + -- Check that the function Is_Nul_Terminated produces correct results + -- whether or not the char_array argument contains the + -- Ada.Interfaces.C.nul character. + + TC_String := "abcdefgh"; + if Is_Nul_Terminated(Item => To_C(TC_String, Append_Nul => False)) then + Report.Failed("Incorrect result from Is_Nul_Terminated when no " & + "nul char is present"); + end if; + + if not Is_Nul_Terminated(To_C(TC_String, Append_Nul => True)) then + Report.Failed("Incorrect result from Is_Nul_Terminated when the " & + "nul char is present"); + end if; + + + -- Now that we've tested the character/char versions of To_Ada and To_C, + -- use them to test the string versions. + + declare + i : size_t := 0; + j : integer := 1; + Incorrect_Conversion : Boolean := False; + + TC_No_nul : constant char_array := To_C(TC_String, False); + TC_nul_Appended : constant char_array := To_C(TC_String, True); + begin + + -- Check that the function To_C produces a char_array result with + -- lower bound of 0, and length dependent upon the Item and + -- Append_Nul parameters (if Append_Nul is True, length is + -- Item'Length + 1; if False, length is Item'Length). + + if TC_No_nul'First /= 0 or TC_nul_Appended'First /= 0 then + Report.Failed("Incorrect lower bound from Function To_C"); + end if; + + if TC_No_nul'Length /= TC_String'Length then + Report.Failed("Incorrect length returned from Function To_C " & + "when Append_Nul => False"); + end if; + + for TC_char in Report.Ident_Char('a')..Report.Ident_Char('h') loop + if TC_No_nul(i) /= To_C(TC_char) or -- Single character To_C. + TC_nul_Appended(i) /= To_C(TC_char) then + Incorrect_Conversion := True; + end if; + i := i + 1; + end loop; + + if Incorrect_Conversion then + Report.Failed("Incorrect result from To_C with string input " & + "and char_array result"); + end if; + + + if TC_nul_Appended'Length /= TC_String'Length + 1 then + Report.Failed("Incorrect length returned from Function To_C " & + "when Append_Nul => True"); + end if; + + if not Is_Nul_Terminated(TC_nul_Appended) then + Report.Failed("No nul appended to the string parameter during " & + "conversion to char_array by function To_C"); + end if; + + + -- Check that the function To_Ada produces a string result with + -- lower bound of 1, and length dependent upon the Item and + -- Trim_Nul parameters (if Trim_Nul is False, length is Item'Length; + -- if True, length will be the length of the slice of Item prior to + -- the first nul). + + declare + TC_No_NUL_String : constant String := + To_Ada(Item => TC_nul_Appended, + Trim_Nul => True); + TC_NUL_Appended_String : constant String := + To_Ada(TC_nul_Appended, False); + begin + + if TC_No_NUL_String'First /= 1 or + TC_NUL_Appended_String'First /= 1 + then + Report.Failed("Incorrect lower bound from Function To_Ada"); + end if; + + if TC_No_NUL_String'Length /= TC_String'Length then + Report.Failed("Incorrect length returned from Function " & + "To_Ada when Trim_Nul => True"); + end if; + + if TC_NUL_Appended_String'Length /= TC_String'Length + 1 then + Report.Failed("Incorrect length returned from Function " & + "To_Ada when Trim_Nul => False"); + end if; + + Start_Character := Report.Ident_Char('a'); + Stop_Character := Report.Ident_Char('h'); + for TC_Character in Start_Character..Stop_Character loop + if TC_No_NUL_String(j) /= TC_Character or + TC_NUL_Appended_String(j) /= TC_Character + then + Report.Failed("Incorrect result from To_Ada with " & + "char_array input, index = " & + Integer'Image(j)); + end if; + j := j + 1; + end loop; + + end; + + + -- Check that the function To_Ada raises Terminator_Error if the + -- parameter Trim_Nul is set to True, but the actual Item parameter + -- does not contain the nul char. + + begin + TC_String := To_Ada(TC_No_nul, Trim_Nul => True); + Report.Failed("Terminator_Error not raised when Item " & + "parameter of To_Ada does not contain the " & + "nul char, but parameter Trim_Nul => True"); + Report.Comment(TC_String & " printed to defeat optimization"); + exception + when Terminator_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by function " & + "To_Ada when the Item parameter does not " & + "contain the nul char, but parameter " & + "Trim_Nul => True"); + end; + + end; + + exception + when The_Error : others => + Report.Failed ("The following exception was raised in the " & + "Test_Block: " & Exception_Name(The_Error)); + end Test_Block; + + Report.Result; + +end CXB30041; diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb3005.a b/gcc/testsuite/ada/acats/tests/cxb/cxb3005.a new file mode 100644 index 000000000..30b940535 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb3005.a @@ -0,0 +1,396 @@ +-- CXB3005.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 the procedure To_C converts the character elements of +-- a string parameter into char elements of the char_array parameter +-- Target, with nul termination if parameter Append_Nul is true. +-- +-- Check that the out parameter Count of procedure To_C is set to the +-- appropriate value for both the nul/no nul terminated cases. +-- +-- Check that Constraint_Error is propagated by procedure To_C if the +-- length of the char_array parameter Target is not sufficient to +-- hold the converted string value. +-- +-- Check that the Procedure To_Ada converts char elements of the +-- char_array parameter Item to the corresponding character elements +-- of string out parameter Target. +-- +-- Check that Constraint_Error is propagated by Procedure To_Ada if the +-- length of string parameter Target is not long enough to hold the +-- converted char_array value. +-- +-- Check that Terminator_Error is propagated by Procedure To_Ada if the +-- parameter Trim_Nul is set to True, but the actual Item parameter +-- contains no nul char. +-- +-- TEST DESCRIPTION: +-- This test uses a variety of String, and char_array objects to test +-- versions of the To_C and To_Ada procedures. +-- +-- This test assumes that the following characters are all included +-- in the implementation defined type Interfaces.C.char: +-- ' ', 'a'..'z', 'A'..'Z', '0'..'9', and '-'. +-- +-- APPLICABILITY CRITERIA: +-- This test is applicable to all implementations that provide +-- package Interfaces.C. If an implementation provides +-- package Interfaces.C, this test must compile, execute, and +-- report "PASSED". +-- +-- CHANGE HISTORY: +-- 01 Sep 95 SAIC Initial prerelease version. +-- 09 May 96 SAIC Incorporated reviewer comments for ACVC 2.1. +-- 26 Oct 96 SAIC Incorporated reviewer comments. +-- 14 Sep 99 RLB Removed incorrect and unnecessary +-- Unchecked_Conversion. +-- +--! + +with Report; +with Interfaces.C; -- N/A => ERROR +with Ada.Characters.Latin_1; +with Ada.Exceptions; +with Ada.Strings.Fixed; + +procedure CXB3005 is +begin + + Report.Test ("CXB3005", "Check that the procedures To_C and To_Ada " & + "produce correct results"); + Test_Block: + declare + + use Interfaces, Interfaces.C; + use Ada.Characters; + use Ada.Exceptions; + use Ada.Strings.Fixed; + + TC_Short_String : String(1..4) := (others => 'x'); + TC_String : String(1..8) := (others => 'y'); + TC_char_array : char_array(0..7) := (others => char'Last); + TC_size_t_Count : size_t := size_t'First; + TC_Natural_Count : Natural := Natural'First; + + + -- We can use the character forms of To_Ada and To_C here to check + -- the results; they were tested in CXB3004. We give them different + -- names to avoid confusion below. + + function Character_to_char (Source : in Character) return char + renames To_C; + function char_to_Character (Source : in char) return Character + renames To_Ada; + + begin + + -- Check that the procedure To_C converts the character elements of + -- a string parameter into char elements of char_array out parameter + -- Target. + -- + -- Case of nul termination. + + TC_String(1..6) := "abcdef"; + + To_C (Item => TC_String(1..6), -- Source slice of length 6. + Target => TC_char_array, -- Length 8 will accommodate nul. + Count => TC_size_t_Count, + Append_Nul => True); + + -- Check that the out parameter Count is set to the appropriate value + -- for the nul terminated case. + + if TC_size_t_Count /= 7 then + Report.Failed("Incorrect setting of out parameter Count by " & + "Procedure To_C when Append_Nul => True"); + end if; + + for i in 1..TC_size_t_Count-1 loop + if char_to_Character(TC_char_array(i-1)) /= TC_String(Integer(i)) + then + Report.Failed("Incorrect result from Procedure To_C when " & + "checking individual char values, case of " & + "Append_Nul => True; " & + "char position = " & Integer'Image(Integer(i))); + end if; + end loop; + + if not Is_Nul_Terminated(TC_char_array) then + Report.Failed("No nul char appended to the char_array result " & + "from Procedure To_C when Append_Nul => True"); + end if; + + if TC_char_array(0..6) /= To_C("abcdef", True) then + Report.Failed("Incorrect result from Procedure To_C when " & + "directly comparing char_array results, case " & + "of Append_Nul => True"); + end if; + + + -- Check Procedure To_C with no nul termination. + + TC_char_array := (others => Character_to_char('M')); -- Reinitialize. + TC_String(1..4) := "WXYZ"; + + To_C (Item => TC_String(1..4), -- Source slice of length 4. + Target => TC_char_array, + Count => TC_size_t_Count, + Append_Nul => False); + + -- Check that the out parameter Count is set to the appropriate value + -- for the non-nul terminated case. + + if TC_size_t_Count /= 4 then + Report.Failed("Incorrect setting of out parameter Count by " & + "Procedure To_C when Append_Nul => False"); + end if; + + for i in 1..TC_size_t_Count loop + if char_to_Character(TC_char_array(i-1)) /= TC_String(Integer(i)) + then + Report.Failed("Incorrect result from Procedure To_C when " & + "checking individual char values, case of " & + "Append_Nul => False; " & + "char position = " & Integer'Image(Integer(i))); + end if; + end loop; + + if Is_Nul_Terminated(TC_char_array) then + Report.Failed("The nul char was appended to the char_array " & + "result of Procedure To_C when Append_Nul => False"); + end if; + + if TC_char_array(0..3) /= To_C("WXYZ", False) then + Report.Failed("Incorrect result from Procedure To_C when " & + "directly comparing char_array results, case " & + "of Append_Nul => False"); + end if; + + + + -- Check that Constraint_Error is raised by procedure To_C if the + -- length of the target char_array parameter is not sufficient to + -- hold the converted string value (plus nul if Append_Nul is True). + + begin + To_C("A string too long", + TC_char_array, + TC_size_t_Count, + Append_Nul => True); + + Report.Failed("Constraint_Error not raised when the Target " & + "parameter of Procedure To_C is not long enough " & + "to hold the converted string"); + Report.Comment(char_to_Character(TC_char_array(0)) & + " printed to defeat optimization"); + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by Procedure " & + "To_C when the Target parameter is not long " & + "enough to contain the char_array result"); + end; + + + + -- Check that the procedure To_Ada converts char elements of the + -- char_array parameter Item to the corresponding character elements + -- of string out parameter Target, with result string length based on + -- the Trim_Nul parameter. + -- + -- Case of appended nul char on the char_array In parameter. + + TC_char_array := To_C ("ACVC-95", Append_Nul => True); -- 8 total chars. + TC_String := (others => '*'); -- Reinitialize. + + To_Ada (Item => TC_char_array, + Target => TC_String, + Count => TC_Natural_Count, + Trim_Nul => False); + + if TC_Natural_Count /= 8 then + Report.Failed("Incorrect value returned in out parameter Count " & + "by Procedure To_Ada, case of Trim_Nul => False"); + end if; + + for i in 1..TC_Natural_Count loop + if Character_to_char(TC_String(i)) /= TC_char_array(size_t(i-1)) + then + Report.Failed("Incorrect result from Procedure To_Ada when " & + "checking individual char values, case of " & + "Trim_Nul => False, when a nul is present in " & + "the char_array input parameter; " & + "position = " & Integer'Image(Integer(i))); + end if; + end loop; + + if TC_String(TC_Natural_Count) /= Latin_1.Nul then + Report.Failed("Last character of String result of Procedure " & + "To_Ada is not Nul, even though a nul was present " & + "in the char_array argument, and the Trim_Nul " & + "parameter was set to False"); + end if; + + + TC_char_array(0..3) := To_C ("XYz", Append_Nul => True); -- 4 chars. + TC_String := (others => '*'); -- Reinit. + + To_Ada (Item => TC_char_array, + Target => TC_String, + Count => TC_Natural_Count, + Trim_Nul => True); + + if TC_Natural_Count /= 3 then + Report.Failed("Incorrect value returned in out parameter Count " & + "by Procedure To_Ada, case of Trim_Nul => True"); + end if; + + for i in 1..TC_Natural_Count loop + if Character_to_char(TC_String(i)) /= TC_char_array(size_t(i-1)) + then + Report.Failed("Incorrect result from Procedure To_Ada when " & + "checking individual char values, case of " & + "Trim_Nul => True, when a nul is present in " & + "the char_array input parameter; " & + "position = " & Integer'Image(Integer(i))); + end if; + end loop; + + if TC_String(TC_Natural_Count) = Latin_1.Nul then + Report.Failed("Last character of String result of Procedure " & + "To_Ada is Nul, even though the Trim_Nul " & + "parameter was set to True"); + end if; + + -- Check that TC_String(TC_Natural_Count+1) is unchanged by procedure + -- To_Ada. + + if TC_String(TC_Natural_Count+1) /= '*' then + Report.Failed("Incorrect modification to TC_String at position " & + Integer'Image(TC_Natural_Count+1) & " expected = " & + "*, found = " & TC_String(TC_Natural_Count+1)); + end if; + + + -- Case of no nul char being present in the char_array argument. + + TC_char_array := To_C ("ABCDWXYZ", Append_Nul => False); + TC_String := (others => '*'); -- Reinitialize. + + To_Ada (Item => TC_char_array, + Target => TC_String, + Count => TC_Natural_Count, + Trim_Nul => False); + + if TC_Natural_Count /= 8 then + Report.Failed("Incorrect value returned in out parameter Count " & + "by Procedure To_Ada, case of Trim_Nul => False, " & + "with no nul char present in the parameter Item"); + end if; + + for i in 1..TC_Natural_Count loop + if Character_to_char(TC_String(i)) /= TC_char_array(size_t(i-1)) + then + Report.Failed("Incorrect result from Procedure To_Ada when " & + "checking individual char values, case of " & + "Trim_Nul => False, when a nul is not present " & + "in the char_array input parameter; " & + "position = " & Integer'Image(Integer(i))); + end if; + end loop; + + if TC_String(TC_Natural_Count) = Latin_1.Nul then + Report.Failed("Last character of String result of Procedure " & + "To_Ada is Nul, even though the nul char was " & + "not present in the parameter Item, with the " & + "parameter Trim_Nul => False"); + end if; + + + + -- Check that the Procedure To_Ada raises Terminator_Error if the + -- parameter Trim_Nul is set to True, but the actual Item parameter + -- does not contain the nul char. + + begin + TC_char_array := To_C ("ABCDWXYZ", Append_Nul => False); + TC_String := (others => '*'); + + To_Ada(TC_char_array, + TC_String, + Count => TC_Natural_Count, + Trim_Nul => True); + + Report.Failed("Terminator_Error not raised when Item " & + "parameter of To_Ada does not contain the " & + "nul char, but parameter Trim_Nul => True"); + Report.Comment(TC_String & " printed to defeat optimization"); + exception + when Terminator_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by Procedure " & + "To_Ada when the Item parameter does not " & + "contain the nul char, but parameter " & + "Trim_Nul => True"); + end; + + + + -- Check that Constraint_Error is propagated by procedure To_Ada if the + -- length of string parameter Target is not long enough to hold the + -- converted char_array value (plus nul if Trim_Nul is False). + + begin + TC_char_array(0..4) := To_C ("ABCD", Append_Nul => True); + + To_Ada(TC_char_array(0..4), -- 4 chars plus nul char. + TC_Short_String, -- Length of 4. + Count => TC_Natural_Count, + Trim_Nul => False); + + Report.Failed("Constraint_Error not raised when string " & + "parameter Target of Procedure To_Ada is not " & + "long enough to hold the converted chars"); + Report.Comment(TC_Short_String & " printed to defeat optimization"); + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by Procedure " & + "To_Ada when string parameter Target is " & + "not long enough to hold the converted chars"); + end; + + + + exception + when The_Error : others => + Report.Failed ("The following exception was raised in the " & + "Test_Block: " & Exception_Name(The_Error)); + end Test_Block; + + Report.Result; + +end CXB3005; diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb30060.c b/gcc/testsuite/ada/acats/tests/cxb/cxb30060.c new file mode 100644 index 000000000..c4df00868 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb30060.c @@ -0,0 +1,174 @@ +/* +-- CXB30060.C +-- +-- 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. +--* +-- +-- FUNCTION NAME: CXB30060 ("wchar_gen") +-- +-- FUNCTION DESCRIPTION: +-- This C function returns the value of type wchar_t corresponding to the +-- value of its parameter, where +-- Val 0 .. 9 ==> '0' .. '9' +-- Val 10 .. 19 ==> 'A' .. 'J' +-- Val 20 .. 29 ==> 'k' .. 't' +-- Val 30 ==> ' ' +-- Val 31 ==> '.' +-- Val 32 ==> ',' +-- +-- INPUT: +-- This function requires that one int parameter be passed to it. +-- +-- OUTPUT: +-- The function will return the appropriate value of type wchar_t. +-- +-- CHANGE HISTORY: +-- 13 Sep 99 RLB Created function to replace incorrect +-- Unchecked_Conversion. +-- +--! +*/ + +#include <stddef.h> + +wchar_t CXB30060 (int val) + +/* NOTE: The above function definition should be accepted by an ANSI-C */ +/* compiler. Older C compilers may reject it; they may, however */ +/* accept the following two lines. An implementation may comment */ +/* out the above function definition and uncomment the following */ +/* one. Otherwise, an implementation must provide the necessary */ +/* modifications to this C code to satisfy the function */ +/* requirements (see Function Description). */ +/* */ +/* wchar_t CXB30060 (val) */ +/* int val; */ +/* */ + +{ wchar_t return_value = ';'; + + switch (val) + { + case 0: + return_value = '0'; + break; + case 1: + return_value = '1'; + break; + case 2: + return_value = '2'; + break; + case 3: + return_value = '3'; + break; + case 4: + return_value = '4'; + break; + case 5: + return_value = '5'; + break; + case 6: + return_value = '6'; + break; + case 7: + return_value = '7'; + break; + case 8: + return_value = '8'; + break; + case 9: + return_value = '9'; + break; + case 10: + return_value = 'A'; + break; + case 11: + return_value = 'B'; + break; + case 12: + return_value = 'C'; + break; + case 13: + return_value = 'D'; + break; + case 14: + return_value = 'E'; + break; + case 15: + return_value = 'F'; + break; + case 16: + return_value = 'G'; + break; + case 17: + return_value = 'H'; + break; + case 18: + return_value = 'I'; + break; + case 19: + return_value = 'J'; + break; + case 20: + return_value = 'k'; + break; + case 21: + return_value = 'l'; + break; + case 22: + return_value = 'm'; + break; + case 23: + return_value = 'n'; + break; + case 24: + return_value = 'o'; + break; + case 25: + return_value = 'p'; + break; + case 26: + return_value = 'q'; + break; + case 27: + return_value = 'r'; + break; + case 28: + return_value = 's'; + break; + case 29: + return_value = 't'; + break; + case 30: + return_value = ' '; + break; + case 31: + return_value = '.'; + break; + case 32: + return_value = ','; + break; + } + + return (return_value); /* Return character value */ +} diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb3007.a b/gcc/testsuite/ada/acats/tests/cxb/cxb3007.a new file mode 100644 index 000000000..3837e0bae --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb3007.a @@ -0,0 +1,408 @@ +-- CXB3007.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 the procedure To_C converts the Wide_Character elements +-- of a Wide_String parameter into wchar_t elements of the wchar_array +-- parameter Target, with wide_nul termination if parameter Append_Nul +-- is true. +-- +-- Check that the out parameter Count of procedure To_C is set to the +-- appropriate value for both the wide_nul/no wide_nul terminated cases. +-- +-- Check that Constraint_Error is propagated by procedure To_C if the +-- length of the wchar_array parameter Target is not sufficient to +-- hold the converted Wide_String value. +-- +-- Check that the Procedure To_Ada converts wchar_t elements of the +-- wchar_array parameter Item to the corresponding Wide_Character +-- elements of Wide_String out parameter Target. +-- +-- Check that Constraint_Error is propagated by Procedure To_Ada if the +-- length of Wide_String parameter Target is not long enough to hold the +-- converted wchar_array value. +-- +-- Check that Terminator_Error is propagated by Procedure To_Ada if the +-- parameter Trim_Nul is set to True, but the actual Item parameter +-- contains no wide_nul wchar_t. +-- +-- TEST DESCRIPTION: +-- This test uses a variety of Wide_String, and wchar_array objects to +-- test versions of the To_C and To_Ada procedures. +-- +-- This test assumes that the following characters are all included +-- in the implementation defined type Interfaces.C.wchar_t: +-- ' ', 'a'..'z', 'A'..'Z', and '-'. +-- +-- APPLICABILITY CRITERIA: +-- This test is applicable to all implementations that provide +-- package Interfaces.C. If an implementation provides +-- package Interfaces.C, this test must compile, execute, and +-- report "PASSED". +-- +-- CHANGE HISTORY: +-- 01 Sep 95 SAIC Initial prerelease version. +-- 09 May 96 SAIC Incorporated reviewer comments for ACVC 2.1. +-- 26 Oct 96 SAIC Incorporated reviewer comments. +-- 14 Sep 99 RLB Removed incorrect and unnecessary +-- Unchecked_Conversion. +-- +--! + +with Report; +with Interfaces.C; -- N/A => ERROR +with Ada.Characters.Latin_1; +with Ada.Characters.Handling; +with Ada.Exceptions; +with Ada.Strings.Wide_Fixed; + +procedure CXB3007 is +begin + + Report.Test ("CXB3007", "Check that the procedures To_C and To_Ada " & + "for wide strings produce correct results"); + Test_Block: + declare + + use Interfaces, Interfaces.C; + use Ada.Characters, Ada.Characters.Handling; + use Ada.Exceptions; + use Ada.Strings.Wide_Fixed; + + TC_Short_Wide_String : Wide_String(1..4) := + (others => Wide_Character'First); + TC_Wide_String : Wide_String(1..8) := + (others => Wide_Character'First); + TC_wchar_array : wchar_array(0..7) := (others => wchar_t'First); + TC_size_t_Count : size_t := size_t'First; + TC_Natural_Count : Natural := Natural'First; + + + -- We can use the wide character forms of To_Ada and To_C here to check + -- the results; they were tested in CXB3006. We give them different + -- names to avoid confusion below. + + function Wide_Character_to_wchar_t (Source : in Wide_Character) + return wchar_t renames To_C; + function wchar_t_to_Wide_Character (Source : in wchar_t) + return Wide_Character renames To_Ada; + + begin + + -- Check that the procedure To_C converts the Wide_Character elements + -- of a Wide_String parameter into wchar_t elements of wchar_array out + -- parameter Target. + -- + -- Case of wide_nul termination. + + TC_Wide_String(1..6) := "abcdef"; + + To_C (Item => TC_Wide_String(1..6), -- Source slice of length 6. + Target => TC_wchar_array, + Count => TC_size_t_Count, + Append_Nul => True); + + -- Check that the out parameter Count is set to the appropriate value + -- for the wide_nul terminated case. + + if TC_size_t_Count /= 7 then + Report.Failed("Incorrect setting of out parameter Count by " & + "Procedure To_C when Append_Nul => True"); + end if; + + for i in 1..TC_size_t_Count-1 loop + if wchar_t_to_Wide_Character(TC_wchar_array(i-1)) /= + TC_Wide_String(Integer(i)) + then + Report.Failed("Incorrect result from Procedure To_C when " & + "checking individual wchar_t values, case of " & + "Append_Nul => True; " & + "wchar_t position = " & Integer'Image(Integer(i))); + end if; + end loop; + + if not Is_Nul_Terminated(TC_wchar_array) then + Report.Failed("No wide_nul wchar_t appended to the wchar_array " & + "result from Procedure To_C when Append_Nul => True"); + end if; + + if TC_wchar_array(0..6) /= To_C("abcdef", True) then + Report.Failed("Incorrect result from Procedure To_C when " & + "directly comparing wchar_array results, case " & + "of Append_Nul => True"); + end if; + + + -- Check Procedure To_C with no wide_nul termination. + + TC_wchar_array := (others => Wide_Character_to_wchar_t('M')); + TC_Wide_String(1..4) := "WXYZ"; + + To_C (Item => TC_Wide_String(1..4), -- Source slice of length 4. + Target => TC_wchar_array, + Count => TC_size_t_Count, + Append_Nul => False); + + -- Check that the out parameter Count is set to the appropriate value + -- for the non-wide_nul terminated case. + + if TC_size_t_Count /= 4 then + Report.Failed("Incorrect setting of out parameter Count by " & + "Procedure To_C when Append_Nul => False"); + end if; + + for i in 1..TC_size_t_Count loop + if wchar_t_to_Wide_Character(TC_wchar_array(i-1)) /= + TC_Wide_String(Integer(i)) + then + Report.Failed("Incorrect result from Procedure To_C when " & + "checking individual wchar_t values, case of " & + "Append_Nul => False; " & + "wchar_t position = " & Integer'Image(Integer(i))); + end if; + end loop; + + if Is_Nul_Terminated(TC_wchar_array) then + Report.Failed + ("The wide_nul wchar_t was appended to the wchar_array " & + "result of Procedure To_C when Append_Nul => False"); + end if; + + if TC_wchar_array(0..3) /= To_C("WXYZ", False) then + Report.Failed("Incorrect result from Procedure To_C when " & + "directly comparing wchar_array results, case " & + "of Append_Nul => False"); + end if; + + + + -- Check that Constraint_Error is raised by procedure To_C if the + -- length of the target wchar_array parameter is not sufficient to + -- hold the converted Wide_String value (plus wide_nul if Append_Nul + -- is True). + + TC_wchar_array := (others => wchar_t'First); + begin + To_C("A string too long", + TC_wchar_array, + TC_size_t_Count, + Append_Nul => True); + + Report.Failed("Constraint_Error not raised when the Target " & + "parameter of Procedure To_C is not long enough " & + "to hold the converted Wide_String"); + Report.Comment + (To_Character(wchar_t_to_Wide_Character(TC_wchar_array(0))) & + " printed to defeat optimization"); + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by Procedure " & + "To_C when the Target parameter is not long " & + "enough to contain the wchar_array result"); + end; + + + + -- Check that the procedure To_Ada converts wchar_t elements of the + -- wchar_array parameter Item to the corresponding Wide_Character + -- elements of Wide_String out parameter Target, with result wide + -- string length based on the Trim_Nul parameter. + -- + -- Case of appended wide_nul wchar_t on the wchar_array In parameter. + + TC_wchar_array := + To_C ("ACVC-95", Append_Nul => True); -- 8 total chars. + + To_Ada (Item => TC_wchar_array, + Target => TC_Wide_String, + Count => TC_Natural_Count, + Trim_Nul => False); + + if TC_Natural_Count /= 8 then + Report.Failed("Incorrect value returned in out parameter Count " & + "by Procedure To_Ada, case of Trim_Nul => False"); + end if; + + for i in 1..TC_Natural_Count loop + if Wide_Character_to_wchar_t(TC_Wide_String(i)) /= + TC_wchar_array(size_t(i-1)) + then + Report.Failed("Incorrect result from Procedure To_Ada when " & + "checking individual wchar_t values, case of " & + "Trim_Nul => False, when a wide_nul is present " & + "in the wchar_array input parameter; " & + "position = " & Integer'Image(Integer(i))); + end if; + end loop; + + if TC_Wide_String(TC_Natural_Count) /= To_Wide_Character(Latin_1.Nul) + then + Report.Failed("Last Wide_Character of Wide_String result of " & + "Procedure To_Ada is not Nul, even though a " & + "wide_nul was present in the wchar_array argument, " & + "and the Trim_Nul parameter was set to False"); + end if; + + + TC_Wide_String := (others => Wide_Character'First); + TC_wchar_array(0..3) := To_C ("XYz", Append_Nul => True); -- 4 chars. + + To_Ada (Item => TC_wchar_array, + Target => TC_Wide_String, + Count => TC_Natural_Count, + Trim_Nul => True); + + if TC_Natural_Count /= 3 then + Report.Failed("Incorrect value returned in out parameter Count " & + "by Procedure To_Ada, case of Trim_Nul => True"); + end if; + + for i in 1..TC_Natural_Count loop + if Wide_Character_to_wchar_t(TC_Wide_String(i)) /= + TC_wchar_array(size_t(i-1)) + then + Report.Failed("Incorrect result from Procedure To_Ada when " & + "checking individual wchar_t values, case of " & + "Trim_Nul => True, when a wide_nul is present " & + "in the wchar_array input parameter; " & + "position = " & Integer'Image(Integer(i))); + end if; + end loop; + + if TC_Wide_String(TC_Natural_Count) = To_Wide_Character(Latin_1.Nul) + then + Report.Failed("Last Wide_Character of Wide_String result of " & + "Procedure To_Ada is Nul, even though the " & + "Trim_Nul parameter was set to True"); + end if; + + if TC_Wide_String(TC_Natural_Count+1) /= Wide_Character'First then + Report.Failed("Incorrect replacement from To_Ada"); + end if; + + + -- Case of no wide_nul wchar_t present in the wchar_array argument. + + TC_Wide_String := (others => Wide_Character'First); + TC_wchar_array := To_C ("ABCDWXYZ", Append_Nul => False); + + To_Ada (Item => TC_wchar_array, + Target => TC_Wide_String, + Count => TC_Natural_Count, + Trim_Nul => False); + + if TC_Natural_Count /= 8 then + Report.Failed("Incorrect value returned in out parameter Count " & + "by Procedure To_Ada, case of Trim_Nul => False, " & + "with no wide_nul wchar_t present in the parameter " & + "Item"); + end if; + + for i in 1..TC_Natural_Count loop + if Wide_Character_to_wchar_t(TC_Wide_String(i)) /= + TC_wchar_array(size_t(i-1)) + then + Report.Failed("Incorrect result from Procedure To_Ada when " & + "checking individual wchar_t values, case of " & + "Trim_Nul => False, when a wide_nul is not " & + "present in the wchar_array input parameter; " & + "position = " & Integer'Image(Integer(i))); + end if; + end loop; + + if TC_Wide_String(TC_Natural_Count) = To_Wide_Character(Latin_1.Nul) + then + Report.Failed("Last Wide_Character of Wide_String result of " & + "Procedure To_Ada is Nul, even though the wide_nul " & + "wchar_t was not present in the parameter Item, " & + "with the parameter Trim_Nul => False"); + end if; + + + + -- Check that the Procedure To_Ada raises Terminator_Error if the + -- parameter Trim_Nul is set to True, but the actual Item parameter + -- does not contain the wide_nul wchar_t. + + begin + TC_Wide_String := (others => Wide_Character'First); + TC_wchar_array := To_C ("ABCDWXYZ", Append_Nul => False); + + To_Ada(TC_wchar_array, + TC_Wide_String, + Count => TC_Natural_Count, + Trim_Nul => True); + + Report.Failed("Terminator_Error not raised when Item " & + "parameter of To_Ada does not contain the " & + "wide_nul wchar_t, but parameter Trim_Nul => True"); + Report.Comment(To_String(TC_Wide_String) & + " printed to defeat optimization"); + exception + when Terminator_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by Procedure " & + "To_Ada when the Item parameter does not " & + "contain the wide_nul wchar_t, but parameter " & + "Trim_Nul => True"); + end; + + + + -- Check that Constraint_Error is propagated by procedure To_Ada if the + -- length of Wide_String parameter Target is not long enough to hold the + -- converted wchar_array value (plus wide_nul if Trim_Nul is False). + + begin + TC_wchar_array(0..4) := To_C ("ABCD", Append_Nul => True); + + To_Ada(TC_wchar_array(0..4), + TC_Short_Wide_String, -- Length of 4. + Count => TC_Natural_Count, + Trim_Nul => False); + + Report.Failed("Constraint_Error not raised when Wide_String " & + "parameter Target of Procedure To_Ada is not " & + "long enough to hold the converted wchar_ts"); + Report.Comment(To_String(TC_Short_Wide_String) & + " printed to defeat optimization"); + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by Procedure " & + "To_Ada when Wide_String parameter Target is " & + "not long enough to hold the converted wchar_ts"); + end; + + exception + when The_Error : others => + Report.Failed ("The following exception was raised in the " & + "Test_Block: " & Exception_Name(The_Error)); + end Test_Block; + + Report.Result; + +end CXB3007; diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb3008.a b/gcc/testsuite/ada/acats/tests/cxb/cxb3008.a new file mode 100644 index 000000000..9df19d814 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb3008.a @@ -0,0 +1,226 @@ +-- CXB3008.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 functions imported from the C language <string.h> and +-- <stdlib.h> libraries can be called from an Ada program. +-- +-- TEST DESCRIPTION: +-- This test checks that C language functions from the <string.h> and +-- <stdlib.h> libraries can be used as completions of Ada subprograms. +-- A pragma Import with convention identifier "C" is used to complete +-- the Ada subprogram specifications. +-- The three subprogram cases tested are as follows: +-- 1) A C function that returns an int value (strcpy) is used as the +-- completion of an Ada procedure specification. The return value +-- is discarded; parameter modification is the desired effect. +-- 2) A C function that returns an int value (strlen) is used as the +-- completion of an Ada function specification. +-- 3) A C function that returns a double value (strtod) is used as the +-- completion of an Ada function specification. +-- +-- This test assumes that the following characters are all included +-- in the implementation defined type Interfaces.C.char: +-- ' ', 'a'..'z', 'A'..'Z', '0'..'9', and '$'. +-- +-- APPLICABILITY CRITERIA: +-- This test is applicable to all implementations that provide +-- packages Interfaces.C and Interfaces.C.Strings. If an +-- implementation provides these packages, this test must compile, +-- execute, and report "PASSED". +-- +-- SPECIAL REQUIREMENTS: +-- The C language library functions used by this test must be +-- available for importing into the test. +-- +-- +-- CHANGE HISTORY: +-- 12 Oct 95 SAIC Initial prerelease version. +-- 09 May 96 SAIC Incorporated reviewer comments for ACVC 2.1. +-- 01 DEC 97 EDS Replaced all references of C function atof with +-- C function strtod. +-- 29 JUN 98 EDS Give Ada function corresponding to strtod a +-- second parameter. +--! + +with Report; +with Ada.Exceptions; +with Interfaces.C; -- N/A => ERROR +with Interfaces.C.Strings; -- N/A => ERROR +with Interfaces.C.Pointers; + +procedure CXB3008 is +begin + + Report.Test ("CXB3008", "Check that functions imported from the " & + "C language predefined libraries can be " & + "called from an Ada program"); + + Test_Block: + declare + + package IC renames Interfaces.C; + package ICS renames Interfaces.C.Strings; + package ICP is new Interfaces.C.Pointers + ( Index => IC.size_t, + Element => IC.char, + Element_Array => IC.char_array, + Default_Terminator => IC.nul ); + use Ada.Exceptions; + + use type IC.char; + use type IC.char_array; + use type IC.size_t; + use type IC.double; + + -- The String_Copy procedure copies the string pointed to by Source, + -- including the terminating nul char, into the char_array pointed + -- to by Target. + + procedure String_Copy (Target : out IC.char_array; + Source : in IC.char_array); + + -- The String_Length function returns the length of the nul-terminated + -- string pointed to by The_String. The nul is not included in + -- the count. + + function String_Length (The_String : in IC.char_array) + return IC.size_t; + + -- The String_To_Double function converts the char_array pointed to + -- by The_String into a double value returned through the function + -- name. The_String must contain a valid floating-point number; if + -- not, the value returned is zero. + +-- type Acc_ptr is access IC.char_array; + function String_To_Double (The_String : in IC.char_array ; + End_Ptr : ICP.Pointer := null) + return IC.double; + + + -- Use the <string.h> strcpy function as a completion to the procedure + -- specification. Note that the Ada interface to this C function is + -- in the form of a procedure (C function return value is not used). + + pragma Import (C, String_Copy, "strcpy"); + + -- Use the <string.h> strlen function as a completion to the + -- String_Length function specification. + + pragma Import (C, String_Length, "strlen"); + + -- Use the <stdlib.h> strtod function as a completion to the + -- String_To_Double function specification. + + pragma Import (C, String_To_Double, "strtod"); + + + TC_String : constant String := "Just a Test"; + Char_Source : IC.char_array(0..30); + Char_Target : IC.char_array(0..30); + Double_Result : IC.double; + Source_Ptr, + Target_Ptr : ICS.chars_ptr; + + begin + + -- Check that the imported version of C function strcpy produces + -- the correct results. + + Char_Source(0..21) := "Test of Pragma Import" & IC.nul; + + String_Copy(Char_Target, Char_Source); + + if Char_Target(0..21) /= Char_Source(0..21) then + Report.Failed("Incorrect result from the imported version of " & + "strcpy - 1"); + end if; + + if String_Length(Char_Target) /= 21 then + Report.Failed("Incorrect result from the imported version of " & + "strlen - 1"); + end if; + + Char_Source(0) := IC.nul; + + String_Copy(Char_Target, Char_Source); + + if Char_Target(0) /= Char_Source(0) then + Report.Failed("Incorrect result from the imported version of " & + "strcpy - 2"); + end if; + + if String_Length(Char_Target) /= 0 then + Report.Failed("Incorrect result from the imported version of " & + "strlen - 2"); + end if; + + -- The following chars_ptr designates a char_array of 12 chars + -- (including the terminating nul char). + Source_Ptr := ICS.New_Char_Array(IC.To_C(TC_String)); + + String_Copy(Char_Target, ICS.Value(Source_Ptr)); + + Target_Ptr := ICS.New_Char_Array(Char_Target); + + if ICS.Value(Target_Ptr) /= TC_String then + Report.Failed("Incorrect result from the imported version of " & + "strcpy - 3"); + end if; + + if String_Length(ICS.Value(Target_Ptr)) /= TC_String'Length then + Report.Failed("Incorrect result from the imported version of " & + "strlen - 3"); + end if; + + + Char_Source(0..9) := "100.00only"; + + Double_Result := String_To_Double(Char_Source); + + Char_Source(0..13) := "5050.00$$$$$$$"; + + if Double_Result + String_To_Double(Char_Source) /= 5150.00 then + Report.Failed("Incorrect result returned from the imported " & + "version of function strtod - 1"); + end if; + + Char_Source(0..9) := "xxx$10.00x"; -- String doesn't contain a + -- valid floating point value. + if String_To_Double(Char_Source) /= 0.0 then + Report.Failed("Incorrect result returned from the imported " & + "version of function strtod - 2"); + end if; + + + exception + when The_Error : others => + Report.Failed ("The following exception was raised in the " & + "Test_Block: " & Exception_Name(The_Error)); + end Test_Block; + + Report.Result; + +end CXB3008; diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb3009.a b/gcc/testsuite/ada/acats/tests/cxb/cxb3009.a new file mode 100644 index 000000000..3ea5a6204 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb3009.a @@ -0,0 +1,305 @@ +-- CXB3009.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 the function To_Chars_Ptr will return a Null_Ptr value +-- when the parameter Item is null. If the parameter Item is not null, +-- and references a chars_array object that does contain the char nul, +-- and parameter Nul_Check is True, check that To_Chars_Ptr performs a +-- pointer conversion from char_array_access type to chars_ptr type. +-- Check that if parameter Item is not null, and references a +-- chars_array object that does not contain nul, and parameter Nul_Check +-- is True, the To_Chars_Ptr function will propagate Terminator_Error. +-- Check that if parameter Item is not null, and parameter Nul_Check +-- is False, check that To_Chars_Ptr performs a pointer conversion from +-- char_array_access type to chars_ptr type. +-- +-- Check that the New_Char_Array function will return a chars_ptr type +-- pointer to an allocated object that has been initialized with +-- the value of parameter Chars. +-- +-- Check that the function New_String returns a chars_ptr initialized +-- to a nul-terminated string having the value of the Str parameter. +-- +-- TEST DESCRIPTION: +-- This test uses a variety of of string, char_array, +-- char_array_access and char_ptr values in order to validate the +-- functions under test, and results are compared for both length +-- and content. +-- +-- This test assumes that the following characters are all included +-- in the implementation defined type Interfaces.C.char: +-- ' ', 'a'..'z', and 'A'.. 'Z'. +-- +-- APPLICABILITY CRITERIA: +-- This test is applicable to all implementations that provide +-- package Interfaces.C.Strings. If an implementation provides +-- package Interfaces.C.Strings, this test must compile, execute, and +-- report "PASSED". +-- +-- +-- CHANGE HISTORY: +-- 20 Sep 95 SAIC Initial prerelease version. +-- 09 May 96 SAIC Incorporated reviewer comments for ACVC 2.1. +-- 01 DEC 97 EDS Remove incorrect block of code (previously +-- lines 264-287) +-- 14 Sep 99 RLB Added check for behavior of To_Chars_Ptr when +-- Nul_Check => False. (From Technical +-- Corrigendum 1). +--! + +with Report; +with Interfaces.C.Strings; -- N/A => ERROR +with Ada.Characters.Latin_1; +with Ada.Exceptions; +with Ada.Strings.Fixed; + +procedure CXB3009 is +begin + + Report.Test ("CXB3009", "Check that functions To_Chars_Ptr, " & + "New_Chars_Array, and New_String produce " & + "correct results"); + + Test_Block: + declare + + package IC renames Interfaces.C; + package ICS renames Interfaces.C.Strings; + use Ada.Exceptions; + + use type IC.char_array; + use type IC.size_t; + use type ICS.chars_ptr; + + Null_Char_Array_Access : constant ICS.char_array_access := null; + + Test_String : constant String := "Test String"; + String_With_nul : String(1..6) := "Addnul"; + String_Without_nul : String(1..6) := "No nul"; + + Char_Array_With_nul : IC.char_array(0..6) := + IC.To_C(String_With_nul, True); + Char_Array_Without_nul : IC.char_array(0..5) := + IC.To_C(String_Without_nul, False); + Char_Array_W_nul_Ptr : ICS.char_array_access := + new IC.char_array'(Char_Array_With_nul); + Char_Array_WO_nul_Ptr : ICS.char_array_access := + new IC.char_array'(Char_Array_Without_nul); + + TC_chars_ptr : ICS.chars_ptr; + + TC_size_t : IC.size_t := IC.size_t'First; + + + begin + + -- Check that the function To_Chars_Ptr will return a Null_Ptr value + -- when the parameter Item is null. + + if ICS.To_Chars_Ptr(Item => Null_Char_Array_Access, + Nul_Check => False) /= ICS.Null_Ptr or + ICS.To_Chars_Ptr(Null_Char_Array_Access, + Nul_Check => True) /= ICS.Null_Ptr or + ICS.To_Chars_Ptr(Null_Char_Array_Access) /= ICS.Null_Ptr + then + Report.Failed("Incorrect result from function To_Chars_Ptr " & + "with parameter Item being a null value"); + end if; + + + -- Check that if the parameter Item is not null, and references a + -- chars_array object that does contain the nul char, and parameter + -- Nul_Check is True, function To_Chars_Ptr performs a pointer + -- conversion from char_array_access type to chars_ptr type. + + begin + TC_chars_ptr := ICS.To_Chars_Ptr(Item => Char_Array_W_nul_Ptr, + Nul_Check => True); + + if ICS.Value(TC_chars_ptr) /= String_With_nul or + ICS.Value(TC_chars_ptr) /= Char_Array_With_nul + then + Report.Failed("Incorrect result from function To_Chars_Ptr " & + "with parameter Item being non-null and " & + "containing the nul char"); + end if; + exception + when IC.Terminator_Error => + Report.Failed("Terminator_Error raised during the validation " & + "of Function To_Chars_Ptr"); + when others => + Report.Failed("Unexpected exception raised during the " & + "validation of Function To_Chars_Ptr"); + end; + + -- Check that if parameter Item is not null, and references a + -- chars_array object that does not contain nul, and parameter + -- Nul_Check is True, the To_Chars_Ptr function will propagate + -- Terminator_Error. + + begin + TC_chars_ptr := ICS.To_Chars_Ptr(Char_Array_WO_nul_Ptr, True); + Report.Failed("Terminator_Error was not raised by function " & + "To_Chars_Ptr when given a parameter Item that " & + "is non-null, and does not contain the nul " & + "char, but parameter Nul_Check is True"); + TC_size_t := ICS.Strlen(TC_chars_ptr); -- Use TC_chars_ptr to + -- defeat optimization; + exception + when IC.Terminator_Error => null; -- Expected exception. + when others => + Report.Failed("Incorrect exception raised when function " & + "To_Chars_Ptr is given a parameter Item that " & + "is non-null, and does not contain the nul " & + "char, but parameter Nul_Check is True"); + end; + + -- Check that if the parameter Item is not null, and parameter + -- Nul_Check is False, function To_Chars_Ptr performs a pointer + -- conversion from char_array_access type to chars_ptr type. + + begin + TC_chars_ptr := ICS.To_Chars_Ptr(Item => Char_Array_WO_nul_Ptr, + Nul_Check => False); + + if ICS.Value(TC_chars_ptr, 6) /= String_Without_nul or + ICS.Value(TC_chars_ptr, 6) /= Char_Array_Without_nul + then + Report.Failed("Incorrect result from function To_Chars_Ptr " & + "with parameter Item being non-null and " & + "Nul_Check False"); + end if; + exception + when IC.Terminator_Error => + Report.Failed("Terminator_Error raised during the validation " & + "of Function To_Chars_Ptr"); + when others => + Report.Failed("Unexpected exception raised during the " & + "validation of Function To_Chars_Ptr"); + end; + + + -- Check that the New_Char_Array function will return a chars_ptr type + -- pointer to an allocated object that has been initialized with + -- the value of parameter Chars. + TC_chars_ptr := ICS.New_String(""); + ICS.Free(TC_chars_ptr); -- Reset the chars_ptr to Null_Ptr; + + if TC_chars_ptr /= ICS.Null_Ptr then + Report.Failed("Reset of TC_chars_ptr to Null not successful - 1"); + end if; + + TC_chars_ptr := ICS.New_Char_Array(Chars => Char_Array_With_nul); + + if TC_chars_ptr = ICS.Null_Ptr then -- Check allocation. + Report.Failed + ("No allocation took place in call to New_Char_Array " & + "with a non-null char_array parameter containing a " & + "terminating nul char"); + end if; + + -- Length of allocated array is determined using Strlen since array + -- is nul terminated. Contents of array are validated using Value. + + if ICS.Value (TC_chars_ptr, Length => 7) /= Char_Array_With_nul or + ICS.Strlen(Item => TC_chars_ptr) /= 6 + then + Report.Failed + ("Incorrect length of allocated char_array resulting " & + "from call of New_Char_Array with a non-null " & + "char_array parameter containing a terminating nul char"); + end if; + + ICS.Free(TC_chars_ptr); -- Reset the chars_ptr to Null_Ptr; + if TC_chars_ptr /= ICS.Null_Ptr then + Report.Failed("Reset of TC_chars_ptr to Null not successful - 2"); + end if; + + TC_chars_ptr := ICS.New_Char_Array(Chars => Char_Array_Without_nul); + + if TC_chars_ptr = ICS.Null_Ptr then -- Check allocation. + Report.Failed + ("No allocation took place in call to New_Char_Array " & + "with a non-null char_array parameter that did not " & + "contain a terminating nul char"); + end if; + + -- Function Value is used with the total length of the + -- Char_Array_Without_nul as a parameter to verify the allocation. + + if ICS.Value(Item => TC_chars_ptr, Length => 6) /= + Char_Array_Without_nul or + ICS.Strlen(Item => TC_chars_ptr) /= 6 + then + Report.Failed("Incorrect length of allocated char_array " & + "resulting from call of New_Char_Array with " & + "a non-null char_array parameter that did not " & + "contain a terminating nul char"); + end if; + + + -- Check that the function New_String returns a chars_ptr specifying + -- an allocated object initialized to the value of parameter Str. + + ICS.Free(TC_chars_ptr); -- Reset the chars_ptr to Null_Ptr; + if TC_chars_ptr /= ICS.Null_Ptr then + Report.Failed("Reset of TC_chars_ptr to Null not successful - 3"); + end if; + + TC_chars_ptr := ICS.New_String(Str => Test_String); + + if ICS.Value(TC_chars_ptr) /= Test_String or + ICS.Value(ICS.New_Char_Array(IC.To_C(Test_String,True))) /= + Test_String + then + Report.Failed("Incorrect allocation resulting from function " & + "New_String with a string parameter value"); + end if; + + ICS.Free(TC_chars_ptr); -- Reset the chars_ptr to Null_Ptr; + if TC_chars_ptr /= ICS.Null_Ptr then + Report.Failed("Reset of TC_chars_ptr to Null not successful - 4"); + end if; + + if ICS.Value(ICS.New_String(String_Without_nul)) /= + String_Without_nul or + ICS.Value(ICS.New_Char_Array(IC.To_C(String_Without_nul,False))) /= + String_Without_nul + then + Report.Failed("Incorrect allocation resulting from function " & + "New_String with parameter value String_Without_nul"); + end if; + + + exception + when The_Error : others => + Report.Failed ("The following exception was raised in the " & + "Test_Block: " & Exception_Name(The_Error)); + end Test_Block; + + Report.Result; + +end CXB3009; diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb3010.a b/gcc/testsuite/ada/acats/tests/cxb/cxb3010.a new file mode 100644 index 000000000..25305b22f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb3010.a @@ -0,0 +1,320 @@ +-- CXB3010.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 the Procedure Free resets the parameter Item to +-- Null_Ptr. Check that Free has no effect if Item is Null_Ptr. +-- +-- Check that the version of Function Value with a chars_ptr parameter +-- returning a char_array result returns the prefix of an array of +-- chars. +-- +-- Check that the version of Function Value with a chars_ptr parameter +-- and a size_t parameter returning a char_array result returns +-- the shorter of: +-- 1) the first size_t number of characters, or +-- 2) the characters up to and including the first nul. +-- +-- Check that both of the above versions of Function Value propagate +-- Dereference_Error if the Item parameter is Null_Ptr. +-- +-- TEST DESCRIPTION: +-- This test validates the Procedure Free and two versions of Function +-- Value. A variety of char_array and char_ptr values are provided as +-- input, and results are compared for both length and content. +-- +-- This test assumes that the following characters are all included +-- in the implementation defined type Interfaces.C.char: +-- ' ', 'a'..'z', and 'A'..'Z'. +-- +-- APPLICABILITY CRITERIA: +-- This test is applicable to all implementations that provide +-- package Interfaces.C.Strings. If an implementation provides +-- package Interfaces.C.Strings, this test must compile, execute, +-- and report "PASSED". +-- +-- +-- CHANGE HISTORY: +-- 27 Sep 95 SAIC Initial prerelease version. +-- 13 May 96 SAIC Incorporated reviewer comments for ACVC 2.1. +-- 26 Oct 96 SAIC Incorporated reviewer comments. +-- 01 DEC 97 EDS Replicate line 199 at line 256, to ensure that +-- TC_chars_ptr has a valid pointer. +-- 08 JUL 99 RLB Added a test case to check that Value raises +-- Constraint_Error when Length = 0. (From Technical +-- Corrigendum 1). +-- 25 JAN 01 RLB Repaired previous test case to avoid raising +-- Constraint_Error in test case code. +-- 26 JAN 01 RLB Added an Ident_Int to the test case to prevent +-- optimization. + +--! + +with Report; +with Interfaces.C.Strings; -- N/A => ERROR + +procedure CXB3010 is +begin + + Report.Test ("CXB3010", "Check that Procedure Free and versions of " & + "Function Value produce correct results"); + + Test_Block: + declare + + package IC renames Interfaces.C; + package ICS renames Interfaces.C.Strings; + + use type IC.char_array; + use type IC.size_t; + use type ICS.chars_ptr; + use type IC.char; + + Null_Char_Array_Access : constant ICS.char_array_access := null; + + TC_String_1 : constant String := "Nonul"; + TC_String_2 : constant String := "AbCdE"; + TC_Blank_String : constant String(1..5) := (others => ' '); + + -- The initialization of the following char_array objects + -- includes the appending of a terminating nul char, in order to + -- prevent the erroneous execution of Function Value. + + TC_char_array : IC.char_array := + IC.To_C(TC_Blank_String, True); + TC_char_array_1 : constant IC.char_array := + IC.To_C(TC_String_1, True); + TC_char_array_2 : constant IC.char_array := + IC.To_C(TC_String_2, True); + TC_Blank_char_array : constant IC.char_array := + IC.To_C(TC_Blank_String, True); + + -- This chars_ptr is initialized via the use of New_Chars_Array to + -- avoid erroneous execution of procedure Free. + TC_chars_ptr : ICS.chars_ptr := + ICS.New_Char_Array(TC_Blank_char_array); + + begin + + -- Check that the Procedure Free resets the parameter Item + -- to Null_Ptr. + + if TC_chars_ptr = ICS.Null_Ptr then + Report.Failed("TC_chars_ptr is currently null; it should not be " & + "null since it was given default initialization"); + end if; + + ICS.Free(TC_chars_ptr); + + if TC_chars_ptr /= ICS.Null_Ptr then + Report.Failed("TC_chars_ptr was not set to Null_Ptr by " & + "Procedure Free"); + end if; + + -- Check that Free has no effect if Item is Null_Ptr. + + begin + TC_chars_ptr := ICS.Null_Ptr; -- Ensure pointer is null. + ICS.Free(TC_chars_ptr); + if TC_chars_ptr /= ICS.Null_Ptr then + Report.Failed("TC_chars_ptr was set to a non-Null_Ptr value " & + "by Procedure Free. It was provided as a null " & + "parameter to Free, and there should have been " & + "no effect from a call to Procedure Free"); + end if; + exception + when others => + Report.Failed("Unexpected exception raised by Procedure Free " & + "when parameter Item is Null_Ptr"); + end; + + + -- Check that the version of Function Value with a chars_ptr parameter + -- that returns a char_array result returns an array of chars (up to + -- and including the first nul). + + TC_chars_ptr := ICS.New_Char_Array(TC_char_array_1); + TC_char_array := ICS.Value(Item => TC_chars_ptr); + + if TC_char_array /= TC_char_array_1 or + IC.To_Ada(TC_char_array, True) /= IC.To_Ada(TC_char_array_1) + then + Report.Failed("Incorrect result from Function Value - 1"); + end if; + + TC_chars_ptr := ICS.New_Char_Array(TC_char_array_2); + TC_char_array := ICS.Value(Item => TC_chars_ptr); + + if TC_char_array /= TC_char_array_2 or + IC.To_Ada(TC_char_array, True) /= IC.To_Ada(TC_char_array_2) + then + Report.Failed("Incorrect result from Function Value - 2"); + end if; + + if ICS.Value(Item => ICS.New_String("A little longer string")) /= + IC.To_C("A little longer string") + then + Report.Failed("Incorrect result from Function Value - 3"); + end if; + + + -- Check that the version of Function Value with a chars_ptr parameter + -- and a size_t parameter that returns a char_array result returns + -- the shorter of: + -- 1) the first size_t number of characters, or + -- 2) the characters up to and including the first nul. + + -- Case 1: the first size_t number of characters (less than the + -- total length). + + begin + TC_chars_ptr := ICS.New_Char_Array(TC_char_array_1); + TC_char_array(0..2) := ICS.Value(Item => TC_chars_ptr, Length => 3); + + if TC_char_array(0..2) /= TC_char_array_1(0..2) + then + Report.Failed + ("Incorrect result from Function Value with Length " & + "parameter - 1"); + end if; + exception + when others => + Report.Failed("Exception raised during Case 1 evaluation"); + end; + + -- Case 2: the characters up to and including the first nul. + + TC_chars_ptr := ICS.New_Char_Array(TC_char_array_2); + + -- The length supplied as a parameter exceeds the total length of + -- TC_char_array_2. The result should be the entire TC_char_array_2 + -- including the terminating nul. + + TC_char_array := ICS.Value(Item => TC_chars_ptr, Length => 7); + + if TC_char_array /= TC_char_array_2 or + IC.To_Ada(TC_char_array) /= IC.To_Ada(TC_char_array_2) or + not (IC.Is_Nul_Terminated(TC_char_array)) + then + Report.Failed("Incorrect result from Function Value with Length " & + "parameter - 2"); + end if; + + + -- Check that both of the above versions of Function Value propagate + -- Dereference_Error if the Item parameter is Null_Ptr. + + declare + + -- Declare a dummy function to demonstrate one way that a chars_ptr + -- variable could inadvertantly be set to Null_Ptr prior to a call + -- to Value (below). + function Freedom (Condition : Boolean := False; + Ptr : ICS.chars_ptr) return ICS.chars_ptr is + Pointer : ICS.chars_ptr := Ptr; + begin + if Condition then + ICS.Free(Pointer); + else + null; -- An activity that doesn't set the chars_ptr value to + -- Null_Ptr. + end if; + return Pointer; + end Freedom; + + begin + + begin + TC_char_array := ICS.Value(Item => Freedom(True, TC_chars_ptr)); + Report.Failed + ("Function Value (without Length parameter) did not " & + "raise Dereference_Error when provided a null Item " & + "parameter input value"); + if TC_char_array(0) = '6' then -- Defeat optimization. + Report.Comment("Should never be printed"); + end if; + exception + when ICS.Dereference_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by Function Value " & + "with Item parameter, when the Item parameter " & + "is Null_Ptr"); + end; + + TC_chars_ptr := ICS.New_Char_Array(TC_char_array_2); + begin + TC_char_array := ICS.Value(Item => Freedom(True, TC_chars_ptr), + Length => 4); + Report.Failed + ("Function Value (with Length parameter) did not " & + "raise Dereference_Error when provided a null Item " & + "parameter input value"); + if TC_char_array(0) = '6' then -- Defeat optimization. + Report.Comment("Should never be printed"); + end if; + exception + when ICS.Dereference_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by Function Value " & + "with both Item and Length parameters, when " & + "the Item parameter is Null_Ptr"); + end; + end; + + -- Check that Function Value with two parameters propagates + -- Constraint_Error if Length is 0. + + begin + TC_chars_ptr := ICS.New_Char_Array(TC_char_array_1); + declare + TC : IC.char_array := ICS.Value(Item => TC_chars_ptr, Length => + IC.Size_T(Report.Ident_Int(0))); + begin + Report.Failed + ("Function Value (with Length parameter) did not " & + "raise Constraint_Error when Length = 0"); + if TC'Length <= TC_char_array'Length then + TC_char_array(1..TC'Length) := TC; -- Block optimization of TC. + end if; + end; + + Report.Failed + ("Function Value (with Length parameter) did not " & + "raise Constraint_Error when Length = 0"); + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by Function Value " & + "with both Item and Length parameters, when " & + "Length = 0"); + end; + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + +end CXB3010; diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb3011.a b/gcc/testsuite/ada/acats/tests/cxb/cxb3011.a new file mode 100644 index 000000000..6930407ec --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb3011.a @@ -0,0 +1,282 @@ +-- CXB3011.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 the version of Function Value with a chars_ptr parameter +-- that returns a String result returns an Ada string containing the +-- characters pointed to by the chars_ptr parameter, up to (but not +-- including) the terminating nul. +-- +-- Check that the version of Function Value with a chars_ptr parameter +-- and a size_t parameter that returns a String result returns the +-- shorter of: +-- 1) a String of the first size_t number of characters, or +-- 2) a String of characters up to (but not including) the +-- terminating nul. +-- +-- Check that the Function Strlen returns a size_t result that +-- corresponds to the number of chars in the array pointed to by Item, +-- up to but not including the terminating nul. +-- +-- Check that both of the above versions of Function Value and +-- Function Strlen propagate Dereference_Error if the Item parameter +-- is Null_Ptr. +-- +-- TEST DESCRIPTION: +-- This test validates two versions of Function Value, and the Function +-- Strlen. A series of char_ptr values are provided as input, and +-- results are compared for length or content. +-- +-- This test assumes that the following characters are all included +-- in the implementation defined type Interfaces.C.char: +-- ' ', 'a'..'z', 'A'..'Z', '0'..'9', '*' and '.'. +-- +-- APPLICABILITY CRITERIA: +-- This test is applicable to all implementations that provide +-- package Interfaces.C.Strings. If an implementation provides +-- package Interfaces.C.Strings, this test must compile, execute, +-- and report "PASSED". +-- +-- +-- CHANGE HISTORY: +-- 28 Sep 95 SAIC Initial prerelease version. +-- 13 May 96 SAIC Incorporated reviewer comments for ACVC 2.1. +-- 26 Oct 96 SAIC Incorporated reviewer comments. +-- +--! + +with Report; +with Ada.Characters.Latin_1; +with Interfaces.C.Strings; -- N/A => ERROR + +procedure CXB3011 is +begin + + Report.Test ("CXB3011", "Check that the two versions of Function Value " & + "returning a String result, and the Function " & + "Strlen, produce correct results"); + + Test_Block: + declare + + package IC renames Interfaces.C; + package ICS renames Interfaces.C.Strings; + package ACL1 renames Ada.Characters.Latin_1; + + use type IC.char_array; + use type IC.size_t; + use type ICS.chars_ptr; + + Null_Char_Array_Access : constant ICS.char_array_access := null; + + TC_String : String(1..5) := (others => 'X'); + TC_String_1 : constant String := "*.3*0"; + TC_String_2 : constant String := "Two"; + TC_String_3 : constant String := "Five5"; + TC_Blank_String : constant String(1..5) := (others => ' '); + + TC_char_array : IC.char_array := + IC.To_C(TC_Blank_String, True); + TC_char_array_1 : constant IC.char_array := + IC.To_C(TC_String_1, True); + TC_char_array_2 : constant IC.char_array := + IC.To_C(TC_String_2, True); + TC_char_array_3 : constant IC.char_array := + IC.To_C(TC_String_3, True); + TC_Blank_char_array : constant IC.char_array := + IC.To_C(TC_Blank_String, True); + + TC_chars_ptr : ICS.chars_ptr := + ICS.New_Char_Array(TC_Blank_char_array); + + TC_size_t : IC.size_t := IC.size_t'First; + + + begin + + -- Check that the version of Function Value with a chars_ptr parameter + -- that returns a String result returns an Ada string containing the + -- characters pointed to by the chars_ptr parameter, up to (but not + -- including) the terminating nul. + + TC_chars_ptr := ICS.New_Char_Array(TC_char_array_1); + TC_String := ICS.Value(Item => TC_chars_ptr); + + if TC_String /= TC_String_1 or + TC_String(TC_String'Last) = ACL1.NUL + then + Report.Failed("Incorrect result from Function Value - 1"); + end if; + + TC_chars_ptr := ICS.New_Char_Array(TC_char_array_2); + + if ICS.Value(Item => TC_chars_ptr) /= + IC.To_Ada(ICS.Value(TC_chars_ptr), Trim_Nul => True) + then + Report.Failed("Incorrect result from Function Value - 2"); + end if; + + TC_chars_ptr := ICS.New_Char_Array(TC_char_array_3); + TC_String := ICS.Value(TC_chars_ptr); + + if TC_String /= TC_String_3 or + TC_String(TC_String'Last) = ACL1.NUL + then + Report.Failed("Incorrect result from Function Value - 3"); + end if; + + + -- Check that the version of Function Value with a chars_ptr parameter + -- and a size_t parameter that returns a String result returns the + -- shorter of: + -- 1) a String of the first size_t number of characters, or + -- 2) a String of characters up to (but not including) the + -- terminating nul. + -- + + -- Case 1 : Length parameter specifies a length shorter than total + -- length. + + TC_chars_ptr := ICS.New_Char_Array(TC_char_array_1); + TC_String := "XXXXX"; -- Reinitialize all characters in string. + TC_String(1..5) := ICS.Value(Item => TC_chars_ptr, Length => 6); + + if TC_String(1..4) /= TC_String_1(1..4) or + TC_String(TC_String'Last) = ACL1.NUL + then + Report.Failed("Incorrect result from Function Value - 4"); + end if; + + -- Case 2 : Length parameter specifies total length. + + TC_chars_ptr := ICS.New_Char_Array(TC_char_array_2); + + if ICS.Value(TC_chars_ptr, Length => 5) /= + IC.To_Ada(ICS.Value(TC_chars_ptr), Trim_Nul => True) + then + Report.Failed("Incorrect result from Function Value - 5"); + end if; + + -- Case 3 : Length parameter specifies a length longer than total + -- length. + + TC_chars_ptr := ICS.New_Char_Array(TC_char_array_3); + TC_String := "XXXXX"; -- Reinitialize all characters in string. + TC_String := ICS.Value(TC_chars_ptr, 7); + + if TC_String /= TC_String_3 or + TC_String(TC_String'Last) = ACL1.NUL + then + Report.Failed("Incorrect result from Function Value - 6"); + end if; + + + -- Check that the Function Strlen returns a size_t result that + -- corresponds to the number of chars in the array pointed to by + -- parameter Item, up to but not including the terminating nul. + + TC_chars_ptr := ICS.New_Char_Array(IC.To_C("A longer string value")); + TC_size_t := ICS.Strlen(TC_chars_ptr); + + if TC_size_t /= 21 then + Report.Failed("Incorrect result from Function Strlen - 1"); + end if; + + TC_chars_ptr := ICS.New_Char_Array(TC_char_array_2); + TC_size_t := ICS.Strlen(TC_chars_ptr); + + if TC_size_t /= 3 then -- Nul not included in length. + Report.Failed("Incorrect result from Function Strlen - 2"); + end if; + + TC_chars_ptr := ICS.New_Char_Array(IC.To_C("")); + TC_size_t := ICS.Strlen(TC_chars_ptr); + + if TC_size_t /= 0 then + Report.Failed("Incorrect result from Function Strlen - 3"); + end if; + + + -- Check that both of the above versions of Function Value and + -- function Strlen propagate Dereference_Error if the Item parameter + -- is Null_Ptr. + + begin + TC_chars_ptr := ICS.Null_Ptr; + TC_String := ICS.Value(Item => TC_chars_ptr); + Report.Failed("Function Value (without Length parameter) did not " & + "raise Dereference_Error when provided a null Item " & + "parameter input value"); + if TC_String(1) = '1' then -- Defeat optimization. + Report.Comment("Should never be printed"); + end if; + exception + when ICS.Dereference_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by Function Value " & + "with Item parameter, when the Item parameter " & + "is Null_Ptr"); + end; + + begin + TC_chars_ptr := ICS.Null_Ptr; + TC_String := ICS.Value(Item => TC_chars_ptr, Length => 4); + Report.Failed("Function Value (with Length parameter) did not " & + "raise Dereference_Error when provided a null Item " & + "parameter input value"); + if TC_String(1) = '1' then -- Defeat optimization. + Report.Comment("Should never be printed"); + end if; + exception + when ICS.Dereference_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by Function Value " & + "with both Item and Length parameters, when " & + "the Item parameter is Null_Ptr"); + end; + + begin + TC_chars_ptr := ICS.Null_Ptr; + TC_size_t := ICS.Strlen(Item => TC_chars_ptr); + Report.Failed("Function Strlen did not raise Dereference_Error" & + "when provided a null Item parameter input value"); + if TC_size_t = 35 then -- Defeat optimization. + Report.Comment("Should never be printed"); + end if; + exception + when ICS.Dereference_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by Function Strlen " & + "when the Item parameter is Null_Ptr"); + end; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + +end CXB3011; diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb3012.a b/gcc/testsuite/ada/acats/tests/cxb/cxb3012.a new file mode 100644 index 000000000..3771f6e68 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb3012.a @@ -0,0 +1,392 @@ +-- CXB3012.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 Procedure Update modifies the value pointed to by +-- the chars_ptr parameter Item, starting at the position +-- corresponding to parameter Offset, using the chars in +-- char_array parameter Chars. +-- +-- Check that the version of Procedure Update with a String parameter +-- behaves in the manner described above, but with the character +-- values in the String overwriting the char values in Item. +-- +-- Check that both of the above versions of Procedure Update will +-- propagate Update_Error if Check is True, and if the length of +-- the new chars in Chars, when overlaid starting from position +-- Offset, will overwrite the first nul in Item. +-- +-- TEST DESCRIPTION: +-- This test checks two versions of Procedure Update. In the first +-- version of the procedure, the parameter Chars indicates a char_array +-- argument. These char_array parameters are provided through the use +-- of the To_C function (with String IN parameter), both with and +-- without a terminating nul. In the case below where a terminating nul +-- char is appended, the effect of "updating" the value pointed to by the +-- Item parameter will include its shortening, due to the insertion of +-- this additional nul in the middle of the char_array. +-- +-- In the second version of Procedure Update evaluated here, the string +-- parameter Str is used to modify the char_array pointed to by Item. +-- +-- Finally, both versions of the procedure are evaluated to ensure that +-- they propagate Update_Error and Dereference_Error under the proper +-- conditions. +-- +-- This test assumes that the following characters are all included +-- in the implementation defined type Interfaces.C.char: +-- ' ', 'a'..'z', 'A'..'Z', '0'..'9', '-' and '.'. +-- +-- APPLICABILITY CRITERIA: +-- This test is applicable to all implementations that provide +-- package Interfaces.C.Strings. If an implementation provides +-- package Interfaces.C.Strings, this test must compile, execute, +-- and report "PASSED". +-- +-- +-- CHANGE HISTORY: +-- 05 Oct 95 SAIC Initial prerelease version. +-- 13 May 96 SAIC Incorporated reviewer comments for ACVC 2.1. +-- 26 Oct 96 SAIC Incorporated reviewer comments. +-- 14 Sep 99 RLB Removed incorrect and unnecessary +-- Unchecked_Conversion. Added check for raising +-- of Dereference_Error for Update (From Technical +-- Corrigendum 1). +-- 07 Jan 05 RLB Modified to reflect change to Update by AI-242 +-- (which is expected to be part of Amendment 1). +-- [This version allows either semantics.] + +--! + +with Report; +with Ada.Exceptions; +with Interfaces.C.Strings; -- N/A => ERROR + +procedure CXB3012 is +begin + + Report.Test ("CXB3012", "Check that both versions of Procedure Update " & + "produce correct results"); + + Test_Block: + declare + + package IC renames Interfaces.C; + package ICS renames Interfaces.C.Strings; + use Ada.Exceptions; + + use type IC.char; + use type IC.char_array; + use type IC.size_t; + use type ICS.chars_ptr; + + TC_String_1 : String(1..1) := "J"; + TC_String_2 : String(1..2) := "Ab"; + TC_String_3 : String(1..3) := "xyz"; + TC_String_4 : String(1..4) := "ACVC"; + TC_String_5 : String(1..5) := "1a2b3"; + TC_String_6 : String(1..6) := "---..."; + TC_String_7 : String(1..7) := "AABBBAA"; + TC_String_8 : String(1..8) := "aBcDeFgH"; + TC_String_9 : String(1..9) := "JustATest"; + TC_String_10 : String(1..10) := "0123456789"; + + TC_Result_String_1 : constant String := "JXXXXXXXXX"; + TC_Result_String_2 : constant String := "XXXXXXXXAb"; + TC_Result_String_3 : constant String := "XXXxyz"; + TC_Result_String_4 : constant String := "XACVC"; + TC_Result_String_5 : constant String := "1a2b3"; + TC_Result_String_6 : constant String := "XXX---..."; + + TC_Amd_Result_String_4 : + constant String := "XACVCXXXXX"; + TC_Amd_Result_String_5 : + constant String := "1a2b3XXXXX"; + TC_Amd_Result_String_6 : + constant String := "XXX---...X"; + TC_Amd_Result_String_9 : + constant String := "JustATestX"; + + TC_char_array : IC.char_array(0..10) := IC.To_C("XXXXXXXXXX"); + TC_Result_char_array : IC.char_array(0..10) := IC.To_C("XXXXXXXXXX"); + TC_chars_ptr : ICS.chars_ptr; + TC_Length : IC.size_t; + + begin + + -- Check that Procedure Update modifies the value pointed to by + -- the chars_ptr parameter Item, starting at the position + -- corresponding to parameter Offset, using the chars in + -- char_array parameter Chars. + -- Note: If parameter Chars contains a nul char (such as a + -- terminating nul), the result may be the overall shortening + -- of parameter Item. + + TC_chars_ptr := ICS.New_Char_Array(TC_char_array); + + ICS.Update(Item => TC_chars_ptr, + Offset => 0, + Chars => IC.To_C(TC_String_1, False), -- No nul char. + Check => True); + + if ICS.Value(TC_chars_ptr) /= TC_Result_String_1 then + Report.Failed("Incorrect result from Procedure Update - 1"); + end if; + ICS.Free(TC_chars_ptr); + + + TC_chars_ptr := ICS.New_Char_Array(TC_char_array); + ICS.Update(TC_chars_ptr, + Offset => ICS.Strlen(TC_chars_ptr) - 2, + Chars => IC.To_C(TC_String_2, False), -- No nul char. + Check => True); + + if ICS.Value(TC_chars_ptr) /= TC_Result_String_2 then + Report.Failed("Incorrect result from Procedure Update - 2"); + end if; + ICS.Free(TC_chars_ptr); + + + TC_chars_ptr := ICS.New_Char_Array(TC_char_array); + ICS.Update(TC_chars_ptr, + 3, + Chars => IC.To_C(TC_String_3), -- Nul appended, shortens + Check => False); -- array. + + if ICS.Value(TC_chars_ptr) /= TC_Result_String_3 then + Report.Failed("Incorrect result from Procedure Update - 3"); + end if; + ICS.Free(TC_chars_ptr); + + + TC_chars_ptr := ICS.New_Char_Array(TC_char_array); + ICS.Update(TC_chars_ptr, + 0, + IC.To_C(TC_String_10), -- Complete replacement of array. + Check => False); + + if ICS.Value(TC_chars_ptr) /= TC_String_10 then + Report.Failed("Incorrect result from Procedure Update - 4"); + end if; + + -- Perform a character-by-character comparison of the result of + -- Procedure Update. Note that char_array lower bound is 0, and + -- that the nul char is not compared with any character in the + -- string (since the string is not nul terminated). + begin + TC_Length := ICS.Strlen(TC_chars_ptr); + TC_Result_char_array(0..10) := ICS.Value(TC_chars_ptr); + for i in 0..TC_Length-1 loop + if TC_Result_char_array(i) /= + IC.To_C(TC_String_10(Integer(i+1))) + then + Report.Failed("Incorrect result from the character-by-" & + "character evaluation of the result of " & + "Procedure Update"); + end if; + end loop; + exception + when others => + Report.Failed("Exception raised during the character-by-" & + "character evaluation of the result of " & + "Procedure Update"); + end; + ICS.Free(TC_chars_ptr); + + + + -- Check that the version of Procedure Update with a String rather + -- than a char_array parameter behaves in the manner described above, + -- but with the character values in the String overwriting the char + -- values in Item. + -- + -- Note: In Ada 95, In each of the cases below, the String parameter + -- Str is treated as if it were nul terminated, which means that + -- the char_array pointed to by TC_chars_ptr will be "shortened" + -- so that it ends after the last character of the Str + -- parameter. For Ada 2005, this rule is dropped, so the + -- number of characters remains the same. + + TC_chars_ptr := ICS.New_Char_Array(TC_char_array); + ICS.Update(TC_chars_ptr, 1, TC_String_4, False); + + if ICS.Value(TC_chars_ptr) = TC_Result_String_4 then + Report.Comment("Ada 95 result from Procedure Update - 5"); + elsif ICS.Value(TC_chars_ptr) = TC_Amd_Result_String_4 then + Report.Comment("Amendment 1 result from Procedure Update - 5"); + else + Report.Failed("Incorrect result from Procedure Update - 5"); + end if; + ICS.Free(TC_chars_ptr); + + + TC_chars_ptr := ICS.New_Char_Array(TC_char_array); + ICS.Update(Item => TC_chars_ptr, + Offset => 0, + Str => TC_String_5); + + if ICS.Value(TC_chars_ptr) = TC_Result_String_5 then + Report.Comment("Ada 95 result from Procedure Update - 6"); + elsif ICS.Value(TC_chars_ptr) = TC_Amd_Result_String_5 then + Report.Comment("Amendment 1 result from Procedure Update - 6"); + else + Report.Failed("Incorrect result from Procedure Update - 6"); + end if; + ICS.Free(TC_chars_ptr); + + + TC_chars_ptr := ICS.New_Char_Array(TC_char_array); + ICS.Update(TC_chars_ptr, + 3, + Str => TC_String_6, + Check => True); + + if ICS.Value(TC_chars_ptr) = TC_Result_String_6 then + Report.Comment("Ada 95 result from Procedure Update - 7"); + elsif ICS.Value(TC_chars_ptr) = TC_Amd_Result_String_6 then + Report.Comment("Amendment 1 result from Procedure Update - 7"); + else + Report.Failed("Incorrect result from Procedure Update - 7"); + end if; + ICS.Free(TC_chars_ptr); + + + TC_chars_ptr := ICS.New_Char_Array(TC_char_array); + ICS.Update(TC_chars_ptr, 0, TC_String_9, True); + + if ICS.Value(TC_chars_ptr) = TC_String_9 then + Report.Comment("Ada 95 result from Procedure Update - 8"); + elsif ICS.Value(TC_chars_ptr) = TC_Amd_Result_String_9 then + Report.Comment("Amendment 1 result from Procedure Update - 8"); + else + Report.Failed("Incorrect result from Procedure Update - 8"); + end if; + ICS.Free(TC_chars_ptr); + + -- Check what happens if the string and array are the same size (this + -- is the case that caused the change made by the Amendment). + begin + TC_chars_ptr := ICS.New_Char_Array(TC_char_array); + ICS.Update(Item => TC_chars_ptr, + Offset => 0, + Str => TC_String_10, + Check => True); + if ICS.Value(TC_chars_ptr) = TC_String_10 then + Report.Comment("Amendment 1 result from Procedure Update - 9"); + else + Report.Failed("Incorrect result from Procedure Update - 9"); + end if; + exception + when ICS.Update_Error => + Report.Comment("Ada 95 exception expected from Procedure Update - 9"); + when others => + Report.Failed("Incorrect exception raised by Procedure Update " & + "with Str parameter - 9"); + end; + ICS.Free(TC_chars_ptr); + + + -- Check that both of the above versions of Procedure Update will + -- propagate Update_Error if Check is True, and if the length of + -- the new chars in Chars, when overlaid starting from position + -- Offset, will overwrite the first nul in Item. + + begin + TC_chars_ptr := ICS.New_Char_Array(TC_char_array); + ICS.Update(Item => TC_chars_ptr, + Offset => 5, + Chars => IC.To_C(TC_String_7), + Check => True); + Report.Failed("Update_Error not raised by Procedure Update with " & + "Chars parameter"); + Report.Comment(ICS.Value(TC_chars_ptr) & "used here to defeat " & + "optimization - should never be printed"); + exception + when ICS.Update_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by Procedure Update " & + "with Chars parameter"); + end; + + ICS.Free(TC_chars_ptr); + + begin + TC_chars_ptr := ICS.New_Char_Array(TC_char_array); + ICS.Update(Item => TC_chars_ptr, + Offset => ICS.Strlen(TC_chars_ptr), + Str => TC_String_8); -- Default Check parameter value. + Report.Failed("Update_Error not raised by Procedure Update with " & + "Str parameter"); + Report.Comment(ICS.Value(TC_chars_ptr) & "used here to defeat " & + "optimization - should never be printed"); + exception + when ICS.Update_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by Procedure Update " & + "with Str parameter"); + end; + + ICS.Free(TC_chars_ptr); + + -- Check that both of the above versions of Procedure Update will + -- propagate Dereference_Error if Item is Null_Ptr. + -- Note: Free sets TC_chars_ptr to Null_Ptr. + + begin + ICS.Update(Item => TC_chars_ptr, + Offset => 5, + Chars => IC.To_C(TC_String_7), + Check => True); + Report.Failed("Dereference_Error not raised by Procedure Update with " & + "Chars parameter"); + exception + when ICS.Dereference_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by Procedure Update " & + "with Chars parameter"); + end; + + begin + ICS.Update(Item => TC_chars_ptr, + Offset => ICS.Strlen(TC_chars_ptr), + Str => TC_String_8); -- Default Check parameter value. + Report.Failed("Dereference_Error not raised by Procedure Update with " & + "Str parameter"); + exception + when ICS.Dereference_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by Procedure Update " & + "with Str parameter"); + end; + + exception + when The_Error : others => + Report.Failed ("The following exception was raised in the " & + "Test_Block: " & Exception_Name(The_Error)); + end Test_Block; + + Report.Result; + +end CXB3012; diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb30130.c b/gcc/testsuite/ada/acats/tests/cxb/cxb30130.c new file mode 100644 index 000000000..57662a323 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb30130.c @@ -0,0 +1,86 @@ +/* +-- CXB30130.C +-- +-- 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. +--* +-- +-- FUNCTION NAME: CXB30130 ("square_it") +-- +-- FUNCTION DESCRIPTION: +-- This C function returns the square of num1 through the function +-- name, and returns the square of parameters num2, num3, and num4 +-- through the argument list (modifying the objects pointed to by +-- the parameters). +-- +-- INPUTS: +-- This function requires that four parameters be passed to it. +-- The types of these parameters are, in order: int, pointer to short, +-- pointer to float, and pointer to double. +-- +-- PROCESSING: +-- The function will calculate the square of the int parameter (num1), +-- and return this value as the function result through the function +-- name. The function will also calculate the square of the values +-- pointed to by the remaining three parameters (num2, num3, num4), +-- and will modify the referenced memory locations to contain the +-- squared values. +-- +-- OUTPUTS: +-- The square of num1 is returned through function name. +-- Parameters num2-num4 now point to values that are the squared results +-- of the originally referenced values (i.e., the original values are +-- modified as a result of this function). +-- +-- CHANGE HISTORY: +-- 12 Oct 95 SAIC Initial prerelease version. +-- +--! +*/ + +int CXB30130 (int num1, short* num2, float* num3, double* num4) + +/* NOTE: The above function definition should be accepted by an ANSI-C */ +/* compiler. Older C compilers may reject it; they may, however */ +/* accept the following five lines. An implementation may comment */ +/* out the above function definition and uncomment the following */ +/* one. Otherwise, an implementation must provide the necessary */ +/* modifications to this C code to satisfy the function */ +/* requirements (see Function Description). */ +/* */ +/* int CXB30130 (num1, num2, num3, num4) */ +/* int num1; */ +/* short* num2; */ +/* float* num3; */ +/* double* num4; */ +/* */ + +{ + int return_value = 0; + + return_value = num1 * num1; + *num2 = *num2 * *num2; /* Return square of these parameters through */ + *num3 = *num3 * *num3; /* the parameter list. */ + *num4 = *num4 * *num4; + + return (return_value); /* Return square of num1 through function name */ +} diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb30131.c b/gcc/testsuite/ada/acats/tests/cxb/cxb30131.c new file mode 100644 index 000000000..6cbbdd131 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb30131.c @@ -0,0 +1,104 @@ +/* +-- CXB30131.C +-- +-- 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. +--* +-- +-- FUNCTION NAME: CXB30131 ("combine_two_strings") +-- +-- FUNCTION DESCRIPTION: +-- This C function returns a pointer to the combination of two +-- input strings. +-- +-- INPUTS: +-- This function requires that two parameters be passed to it. +-- The type of both of these parameters are pointer to char (which +-- is used to reference an array of chars). +-- +-- PROCESSING: +-- The function will create a char array that is equal to the combined +-- length of the char arrays referenced by the two input parameters. +-- The char elements contained in the char arrays specified by the +-- parameters will be combined (in order) into this new char array. +-- +-- OUTPUTS: +-- The newly created char array will be returned as the function +-- result through the function name. The char arrays referenced by the +-- two parameters will be unaffected. +-- +-- CHANGE HISTORY: +-- 12 Oct 95 SAIC Initial prerelease version. +-- 26 Oct 96 SAIC Modified temp array initialization. +-- 15 Feb 99 RLB Repaired to remove non-standard function strdup. +--! +*/ + +#include <string.h> +#include <stdlib.h> + +char *stringdup (char *s) +{ + char *result = malloc(sizeof(char)*(strlen(s)+1)); + return strcpy(result,s); +} + +char *CXB30131 (char *string1, char *string2) + +/* NOTE: The above function definition should be accepted by an ANSI-C */ +/* compiler. Older C compilers may reject it; they may, however */ +/* accept the following three lines. An implementation may comment */ +/* out the above function definition and uncomment the following */ +/* one. Otherwise, an implementation must provide the necessary */ +/* modifications to this C code to satisfy the function */ +/* requirements (see Function Description). */ +/* */ +/* char *CXB30131 (string1, string2) */ +/* char *string1; */ +/* char *string2; */ + +{ + char temp[100]; /* Local array that holds the combined strings */ + int index; /* Loop counter */ + int length = 0; /* Variable that holds the length of the strings */ + + /* Initialize the local array */ + for (index = 0; index < 100; index++) + { temp[index] = 0; } + + /* Use the library function strcpy to copy the contents of string1 + into temp. */ + strcpy (temp, string1); + + /* Use the library function strlen to determine the number of + characters in the temp array (without the trailing nul). */ + length = strlen (temp); + + /* Add each character in string2 into the temp array, add nul + to the end of the array. */ + for (index = length; *string2 != '\0'; index++) + { temp[index] = *string2++; } + temp[index] = '\0'; + + /* Use the library function strdup to return a pointer to temp. */ + return (stringdup(temp)); +} diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb30132.am b/gcc/testsuite/ada/acats/tests/cxb/cxb30132.am new file mode 100644 index 000000000..4cff400b8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb30132.am @@ -0,0 +1,205 @@ +-- CXB30132.AM +-- +-- 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 imported, user-defined C language functions can be +-- called from an Ada program. +-- +-- TEST DESCRIPTION: +-- This test checks that user-defined C language functions can be +-- imported and referenced from an Ada program. Two C language +-- functions are specified in files CXB30130.C and CXB30131.C. +-- These two functions are imported to this test program, using two +-- calls to Pragma Import. Each function is then called in this test, +-- and the results of the call are verified. +-- +-- This test assumes that the following characters are all included +-- in the implementation defined type Interfaces.C.char: +-- ' ', 'a'..'z', and 'A'..'Z'. +-- +-- APPLICABILITY CRITERIA: +-- This test is applicable to all implementations that provide +-- packages Interfaces.C and Interfaces.C.Strings. If an +-- implementation provides packages Interfaces.C and +-- Interfaces.C.Strings, this test must compile, execute, and +-- report "PASSED". +-- +-- SPECIAL REQUIREMENTS: +-- The files CXB30130.C and CXB30131.C must be compiled with a C +-- compiler. Implementation dialects of C may require alteration of +-- the C program syntax (see individual C files). +-- +-- Note that the compiled C code must be bound with the compiled Ada +-- code to create an executable image. An implementation must provide +-- the necessary commands to accomplish this. +-- +-- Note that the C code included in CXB30130.C and CXB30131.C conforms +-- to ANSI-C. Modifications to these files may be required for other +-- C compilers. An implementation must provide the necessary +-- modifications to satisfy the function requirements. +-- +-- TEST FILES: +-- The following files comprise this test: +-- +-- CXB30130.C +-- CXB30131.C +-- CXB30132.AM +-- +-- +-- CHANGE HISTORY: +-- 13 Oct 95 SAIC Initial prerelease version. +-- 13 May 96 SAIC Incorporated reviewer comments for ACVC 2.1. +-- 26 Oct 96 SAIC Incorporated reviewer comments. +-- +--! + +with Report; +with Impdef; +with Interfaces.C; -- N/A => ERROR +with Interfaces.C.Strings; -- N/A => ERROR + +procedure CXB30132 is +begin + + Report.Test ("CXB3013", "Check that user-defined C functions can " & + "be imported into an Ada program"); + + Test_Block: + declare + + package IC renames Interfaces.C; + package ICS renames Interfaces.C.Strings; + + use type IC.char_array; + use type IC.int; + use type IC.short; + use type IC.C_float; + use type IC.double; + + type Short_Ptr is access all IC.short; + type Float_Ptr is access all IC.C_float; + type Double_Ptr is access all IC.double; + subtype Char_Array_Type is IC.char_array(0..20); + + TC_Default_int : IC.int := 49; + TC_Default_short : IC.short := 3; + TC_Default_float : IC.C_float := 50.0; + TC_Default_double : IC.double := 1209.0; + + An_Int_Value : IC.int := TC_Default_int; + A_Short_Value : aliased IC.short := TC_Default_short; + A_Float_Value : aliased IC.C_float := TC_Default_float; + A_Double_Value : aliased IC.double := TC_Default_double; + + A_Short_Int_Pointer : Short_Ptr := A_Short_Value'access; + A_Float_Pointer : Float_Ptr := A_Float_Value'access; + A_Double_Pointer : Double_Ptr := A_Double_Value'access; + + Char_Array_1 : Char_Array_Type; + Char_Array_2 : Char_Array_Type; + Char_Pointer : ICS.chars_ptr; + + TC_Char_Array : constant Char_Array_Type := + "Look before you leap" & IC.nul; + TC_Return_int : IC.int := 0; + + -- The Square_It function returns the square of the value The_Int + -- through the function name, and returns the square of the other + -- parameters through the parameter list (the last three parameters + -- are access values). + + function Square_It (The_Int : in IC.int; + The_Short : in Short_Ptr; + The_Float : in Float_Ptr; + The_Double : in Double_Ptr) return IC.int; + + -- The Combine_Strings function returns the result of the catenation + -- of the two string parameters through the function name. + + function Combine_Strings (First_Part : in IC.char_array; + Second_Part : in IC.char_array) + return ICS.chars_ptr; + + + -- Use the user-defined C function square_it as a completion to the + -- function specification above. + + pragma Import (Convention => C, + Entity => Square_It, + External_Name => Impdef.CXB30130_External_Name); + + -- Use the user-defined C function combine_two_strings as a completion + -- to the function specification above. + + pragma Import (C, Combine_Strings, Impdef.CXB30131_External_Name); + + + begin + + -- Check that the imported version of C function CXB30130 produces + -- the correct results. + + TC_Return_int := Square_It (The_Int => An_Int_Value, + The_Short => A_Short_Int_Pointer, + The_Float => A_Float_Pointer, + The_Double => A_Double_Pointer); + + -- Compare the results with the expected results. Note that in the + -- case of the three "pointer" parameters, the objects being pointed + -- to have been modified as a result of the function. + + if TC_Return_int /= An_Int_Value * An_Int_Value or + A_Short_Int_Pointer.all /= TC_Default_short * TC_Default_Short or + A_Short_Value /= TC_Default_short * TC_Default_Short or + A_Float_Pointer.all /= TC_Default_float * TC_Default_float or + A_Float_Value /= TC_Default_float * TC_Default_float or + A_Double_Pointer.all /= TC_Default_double * TC_Default_double or + A_Double_Value /= TC_Default_double * TC_Default_double + then + Report.Failed("Incorrect results returned from function square_it"); + end if; + + + -- Check that two char_array values are combined by the imported + -- C function CXB30131. + + Char_Array_1(0..12) := "Look before " & IC.nul; + Char_Array_2(0..8) := "you leap" & IC.nul; + + Char_Pointer := Combine_Strings (Char_Array_1, Char_Array_2); + + if ICS.Value(Char_Pointer) /= TC_Char_Array then + Report.Failed("Incorrect value returned from imported function " & + "combine_two_strings"); + end if; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + +end CXB30132; diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb3014.a b/gcc/testsuite/ada/acats/tests/cxb/cxb3014.a new file mode 100644 index 000000000..a9b386ffc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb3014.a @@ -0,0 +1,254 @@ +-- CXB3014.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 the Function Value with Pointer and Element +-- parameters will return an Element_Array result of correct size +-- and content (up to and including the first "terminator" Element). +-- +-- Check that the Function Value with Pointer and Length parameters +-- will return an Element_Array result of appropriate size and content +-- (the first Length elements pointed to by the parameter Ref). +-- +-- Check that both versions of Function Value will propagate +-- Interfaces.C.Strings.Dereference_Error when the value of +-- the Ref pointer parameter is null. +-- +-- TEST DESCRIPTION: +-- This test tests that both versions of Function Value from the +-- generic package Interfaces.C.Pointers are available and produce +-- correct results. The generic package is instantiated with size_t, +-- char, char_array, and nul as actual parameters, and subtests are +-- performed on each of the Value functions resulting from this +-- instantiation. +-- For both function versions, a test is performed where a portion of +-- a char_array is to be returned as the function result. Likewise, +-- a test is performed where each version of the function returns the +-- entire char_array referenced by the in parameter Ref. +-- Finally, both versions of Function Value are called with a null +-- pointer reference, to ensure that Dereference_Error is raised in +-- this case. +-- +-- This test assumes that the following characters are all included +-- in the implementation defined type Interfaces.C.char: +-- ' ', 'a'..'z', and 'A'..'Z'. +-- +-- APPLICABILITY CRITERIA: +-- This test is applicable to all implementations that provide +-- packages Interfaces.C.Strings and Interfaces.C.Pointers. If an +-- implementation provides packages Interfaces.C.Strings and +-- Interfaces.C.Pointers, this test must compile, execute, and +-- report "PASSED". +-- +-- +-- CHANGE HISTORY: +-- 19 Oct 95 SAIC Initial prerelease version. +-- 13 May 96 SAIC Incorporated reviewer comments for ACVC 2.1. +-- 23 Oct 96 SAIC Incorporated reviewer comments. +-- +--! + +with Report; +with Interfaces.C.Strings; -- N/A => ERROR +with Interfaces.C.Pointers; -- N/A => ERROR + +procedure CXB3014 is + +begin + + Report.Test ("CXB3014", "Check that versions of the Value function " & + "from package Interfaces.C.Pointers produce " & + "correct results"); + + Test_Block: + declare + + use type Interfaces.C.char, Interfaces.C.size_t; + + Char_a : constant Interfaces.C.char := 'a'; + Char_j : constant Interfaces.C.char := 'j'; + Char_z : constant Interfaces.C.char := 'z'; + + subtype Lower_Case_chars is Interfaces.C.char range Char_a..Char_z; + subtype Char_Range is Interfaces.C.size_t range 0..26; + + Local_nul : aliased Interfaces.C.char := Interfaces.C.nul; + TC_Array_Size : Interfaces.C.size_t := 20; + + TC_String_1 : constant String := "abcdefghij"; + TC_String_2 : constant String := "abcdefghijklmnopqrstuvwxyz"; + TC_String_3 : constant String := "abcdefghijklmnopqrst"; + TC_String_4 : constant String := "abcdefghijklmnopqrstuvwxyz"; + TC_Blank_String : constant String := " "; + + TC_Char_Array : Interfaces.C.char_array(Char_Range) := + Interfaces.C.To_C(TC_String_2, True); + + TC_Char_Array_1 : Interfaces.C.char_array(0..9); + TC_Char_Array_2 : Interfaces.C.char_array(Char_Range); + TC_Char_Array_3 : Interfaces.C.char_array(0..TC_Array_Size-1); + TC_Char_Array_4 : Interfaces.C.char_array(Char_Range); + + package Char_Pointers is new + Interfaces.C.Pointers (Index => Interfaces.C.size_t, + Element => Interfaces.C.char, + Element_Array => Interfaces.C.char_array, + Default_Terminator => Interfaces.C.nul); + + Char_Ptr : Char_Pointers.Pointer; + + use type Char_Pointers.Pointer; + + begin + + -- Check that the Function Value with Pointer and Terminator Element + -- parameters will return an Element_Array result of appropriate size + -- and content (up to and including the first "terminator" Element.) + + Char_Ptr := TC_Char_Array(0)'Access; + + -- Provide a new Terminator char in the call of Function Value. + -- This call should return only a portion (the first 10 chars) of + -- the referenced char_array, up to and including the char 'j'. + + TC_Char_Array_1 := Char_Pointers.Value(Ref => Char_Ptr, + Terminator => Char_j); + + if Interfaces.C.To_Ada(TC_Char_Array_1, False) /= TC_String_1 or + Interfaces.C.Is_Nul_Terminated(TC_Char_Array_1) + then + Report.Failed("Incorrect result from Function Value with Ref " & + "and Terminator parameters, when supplied with " & + "a non-default Terminator char"); + end if; + + -- Use the default Terminator char in the call of Function Value. + -- This call should return the entire char_array, including the + -- terminating nul char. + + TC_Char_Array_2 := Char_Pointers.Value(Char_Ptr); + + if Interfaces.C.To_Ada(TC_Char_Array_2, True) /= TC_String_2 or + not Interfaces.C.Is_Nul_Terminated(TC_Char_Array_2) + then + Report.Failed("Incorrect result from Function Value with Ref " & + "and Terminator parameters, when using the " & + "default Terminator char"); + end if; + + + + -- Check that the Function Value with Pointer and Length parameters + -- will return an Element_Array result of appropriate size and content + -- (the first Length elements pointed to by the parameter Ref). + + -- This call should return only a portion (the first 20 chars) of + -- the referenced char_array. + + TC_Char_Array_3 := + Char_Pointers.Value(Ref => Char_Ptr, + Length => Interfaces.C.ptrdiff_t(TC_Array_Size)); + + -- Verify the individual chars of the result. + for i in 0..TC_Array_Size-1 loop + if Interfaces.C.To_Ada(TC_Char_Array_3(i)) /= + TC_String_3(Integer(i)+1) + then + Report.Failed("Incorrect result from Function Value with " & + "Ref and Length parameters, when specifying " & + "a length less than the full array size"); + exit; + end if; + end loop; + + -- This call should return the entire char_array, including the + -- terminating nul char. + + TC_Char_Array_4 := Char_Pointers.Value(Char_Ptr, 27); + + if Interfaces.C.To_Ada(TC_Char_Array_4, True) /= TC_String_4 or + not Interfaces.C.Is_Nul_Terminated(TC_Char_Array_4) + then + Report.Failed("Incorrect result from Function Value with Ref " & + "and Length parameters, when specifying the " & + "entire array size"); + end if; + + + + -- Check that both of the above versions of Function Value will + -- propagate Interfaces.C.Strings.Dereference_Error when the value of + -- the Ref Pointer parameter is null. + + Char_Ptr := null; + + begin + TC_Char_Array_1 := Char_Pointers.Value(Ref => Char_Ptr, + Terminator => Char_j); + Report.Failed("Dereference_Error not raised by Function " & + "Value with Terminator parameter, when " & + "provided a null reference"); + -- Call Report.Comment to ensure that the assignment to + -- TC_Char_Array_1 is not "dead", and therefore can not be + -- optimized away. + Report.Comment(Interfaces.C.To_Ada(TC_Char_Array_1, False)); + exception + when Interfaces.C.Strings.Dereference_Error => + null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by Function " & + "Value with Terminator parameter, when " & + "provided a null reference"); + end; + + + begin + TC_Char_Array_3 := + Char_Pointers.Value(Char_Ptr, + Interfaces.C.ptrdiff_t(TC_Array_Size)); + Report.Failed("Dereference_Error not raised by Function " & + "Value with Length parameter, when provided " & + "a null reference"); + -- Call Report.Comment to ensure that the assignment to + -- TC_Char_Array_3 is not "dead", and therefore can not be + -- optimized away. + Report.Comment(Interfaces.C.To_Ada(TC_Char_Array_3, False)); + exception + when Interfaces.C.Strings.Dereference_Error => + null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by Function " & + "Value with Length parameter, when " & + "provided a null reference"); + end; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + +end CXB3014; diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb3015.a b/gcc/testsuite/ada/acats/tests/cxb/cxb3015.a new file mode 100644 index 000000000..24ec826fa --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb3015.a @@ -0,0 +1,520 @@ +-- CXB3015.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 the "+" and "-" functions with Pointer and ptrdiff_t +-- parameters that return Pointer values produce correct results, +-- based on the size of the array elements. +-- +-- Check that the "-" function with two Pointer parameters that +-- returns a ptrdiff_t type parameter produces correct results, +-- based on the size of the array elements. +-- +-- Check that each of the "+" and "-" functions above will +-- propagate Pointer_Error if a Pointer parameter is null. +-- +-- Check that the Increment and Decrement procedures provide the +-- correct "pointer arithmetic" operations. +-- +-- TEST DESCRIPTION: +-- This test checks that the functions "+" and "-", and the procedures +-- Increment and Decrement in the generic package Interfaces.C.Pointers +-- will allow the user to perform "pointer arithmetic" operations on +-- Pointer values. +-- Package Interfaces.C.Pointers is instantiated three times, for +-- short values, chars, and arrays of arrays. Pointers from each +-- instantiated package are then used to reference different elements +-- of array objects. Pointer arithmetic operations are performed on +-- these pointers, and the results of these operations are verified +-- against expected pointer positions along the referenced arrays. +-- The propagation of Pointer_Error is checked for when the function +-- Pointer parameter is null. +-- +-- The following chart indicates the combinations of subprograms and +-- parameter types used in this test. +-- +-- +-- Short Char Array +-- -------------------------- +-- "+" Pointer, ptrdiff_t | X | | X | +-- |--------------------------| +-- "+" ptrdiff_t, Pointer | X | | X | +-- |--------------------------| +-- "-" Pointer, ptrdiff_t | | X | X | +-- |--------------------------| +-- "-" Pointer, Pointer | | X | X | +-- |--------------------------| +-- Increment (Pointer) | X | | X | +-- |--------------------------| +-- Decrement (Pointer) | X | | X | +-- -------------------------- +-- +-- This test assumes that the following characters are all included +-- in the implementation defined type Interfaces.C.char: +-- ' ', and 'a'..'z'. +-- +-- APPLICABILITY CRITERIA: +-- This test is applicable to all implementations that provide +-- package Interfaces.C.Pointers. If an implementation provides +-- package Interfaces.C.Pointers, this test must compile, execute, and +-- report "PASSED". +-- +-- +-- CHANGE HISTORY: +-- 26 Oct 95 SAIC Initial prerelease version. +-- 13 May 96 SAIC Incorporated reviewer comments for ACVC 2.1. +-- 26 Oct 96 SAIC Incorporated reviewer comments. +-- 06 Mar 00 RLB Repaired so that array of arrays component +-- type is statically constrained. (C does not have +-- an analog to an array of dynamically constrained +-- arrays.) + +with Report; +with Ada.Exceptions; +with Interfaces.C.Pointers; -- N/A => ERROR + +procedure CXB3015 is +begin + + Report.Test ("CXB3015", "Check that +, -, Increment, and Decrement " & + "subprograms in Package Interfaces.C.Pointers " & + "produce correct results"); + + Test_Block: + declare + + use Ada.Exceptions; + use type Interfaces.C.short; + use type Interfaces.C.size_t, Interfaces.C.ptrdiff_t; + use type Interfaces.C.char, Interfaces.C.char_array; + + TC_Count : Interfaces.C.size_t; + TC_Increment : Interfaces.C.ptrdiff_t; + TC_ptrdiff_t : Interfaces.C.ptrdiff_t; + TC_Short : Interfaces.C.short := 0; + TC_Verbose : Boolean := False; + Constant_Min_Array_Size : constant Interfaces.C.size_t := 0; + Constant_Max_Array_Size : constant Interfaces.C.size_t := 20; + Min_Array_Size : Interfaces.C.size_t := Interfaces.C.size_t( + Report.Ident_Int(Integer(Constant_Min_Array_Size))); + Max_Array_Size : Interfaces.C.size_t := Interfaces.C.size_t( + Report.Ident_Int(Integer(Constant_Max_Array_Size))); + Min_size_t, + Max_size_t : Interfaces.C.size_t; + Short_Terminator : Interfaces.C.short := Interfaces.C.short'Last; + Alphabet : constant String := "abcdefghijklmnopqrstuvwxyz"; + + + type Short_Array_Type is + array (Interfaces.C.size_t range <>) of aliased Interfaces.C.short; + + type Constrained_Array_Type is + array (Min_Array_Size..Max_Array_Size) of aliased Interfaces.C.short; + + type Static_Constrained_Array_Type is + array (Constant_Min_Array_Size .. Constant_Max_Array_Size) of + aliased Interfaces.C.short; + + type Array_of_Arrays_Type is + array (Interfaces.C.size_t range <>) of aliased + Static_Constrained_Array_Type; + + + Short_Array : Short_Array_Type(Min_Array_Size..Max_Array_Size); + + Constrained_Array : Constrained_Array_Type; + + Terminator_Array : Static_Constrained_Array_Type := + (others => Short_Terminator); + + Ch_Array : Interfaces.C.char_array + (0..Interfaces.C.size_t(Alphabet'Length)) := + Interfaces.C.To_C(Alphabet, True); + + Array_of_Arrays : Array_of_Arrays_Type + (Min_Array_Size..Max_Array_Size); + + + package Short_Pointers is new + Interfaces.C.Pointers (Index => Interfaces.C.size_t, + Element => Interfaces.C.short, + Element_Array => Short_Array_Type, + Default_Terminator => Short_Terminator); + + package Char_Pointers is new + Interfaces.C.Pointers (Interfaces.C.size_t, + Interfaces.C.char, + Element_Array => Interfaces.C.char_array, + Default_Terminator => Interfaces.C.nul); + + package Array_Pointers is new + Interfaces.C.Pointers (Interfaces.C.size_t, + Static_Constrained_Array_Type, + Array_of_Arrays_Type, + Terminator_Array); + + + use Short_Pointers, Char_Pointers, Array_Pointers; + + Short_Ptr : Short_Pointers.Pointer := Short_Array(0)'Access; + Char_Ptr : Char_Pointers.Pointer := Ch_Array(0)'Access; + Start_Char_Ptr : Char_Pointers.Pointer := Ch_Array(1)'Access; + End_Char_Ptr : Char_Pointers.Pointer := Ch_Array(10)'Access; + Array_Ptr : Array_Pointers.Pointer := Array_of_Arrays(0)'Access; + Start_Array_Ptr : Array_Pointers.Pointer := Array_of_Arrays(1)'Access; + End_Array_Ptr : Array_Pointers.Pointer := Array_of_Arrays(10)'Access; + + begin + + -- Provide initial values for the arrays that hold short int values. + + for i in Min_Array_Size..Max_Array_Size-1 loop + Short_Array(i) := Interfaces.C.short(i); + for j in Min_Array_Size..Max_Array_Size loop + -- Initialize this "array of arrays" so that element (i)(0) + -- is different for each value of i. + Array_of_Arrays(i)(j) := TC_Short; + TC_Short := TC_Short + 1; + end loop; + end loop; + + -- Set the final element of each array object to be the "terminator" + -- element used in the instantiations above. + + Short_Array(Max_Array_Size) := Short_Terminator; + Array_of_Arrays(Max_Array_Size) := Terminator_Array; + + -- Check starting pointer positions. + + if Short_Ptr.all /= 0 or + Char_Ptr.all /= Ch_Array(0) or + Array_Ptr.all /= Array_of_Arrays(0) + then + Report.Failed("Incorrect initial value for the first " & + "Short_Array, Ch_Array, or Array_of_Array values"); + end if; + + + -- Check that both versions of the "+" function with Pointer and + -- ptrdiff_t parameters, that return a Pointer value, produce correct + -- results, based on the size of the array elements. + + for i in Min_Array_Size + 1 .. Max_Array_Size loop + + if Integer(i)/2*2 /= Integer(i) then -- Odd numbered loops. + -- Pointer + ptrdiff_t, increment by 1. + Short_Ptr := Short_Ptr + 1; + else -- Even numbered loops. + -- ptrdiff_t + Pointer, increment by 1. + Short_Ptr := 1 + Short_Ptr; + end if; + + if Short_Ptr.all /= Short_Array(i) then + Report.Failed("Incorrect value returned following use " & + "of the function +, incrementing by 1, " & + "array position : " & Integer'Image(Integer(i))); + if not TC_Verbose then + exit; + end if; + end if; + end loop; + + Array_Ptr := Array_of_Arrays(Min_Array_Size)'Access; + TC_Count := Min_Array_Size; + TC_Increment := 3; + while TC_Count+Interfaces.C.size_t(TC_Increment) < Max_Array_Size loop + + if Integer(TC_Count)/2*2 /= Integer(TC_Count) then + -- Odd numbered loops. + -- Pointer + ptrdiff_t, increment by 3. + Array_Ptr := Array_Pointers."+"(Array_Ptr, TC_Increment); + else + -- Odd numbered loops. + -- ptrdiff_t + Pointer, increment by 3. + Array_Ptr := Array_Pointers."+"(Left => TC_Increment, + Right => Array_Ptr); + end if; + + if Array_Ptr.all /= + Array_of_Arrays(TC_Count+Interfaces.C.size_t(TC_Increment)) + then + Report.Failed("Incorrect value returned following use " & + "of the function +, incrementing by " & + Integer'Image(Integer(TC_Increment)) & + ", array position : " & + Integer'Image(Integer(TC_Count) + + Integer(TC_Increment))); + if not TC_Verbose then + exit; + end if; + end if; + + TC_Count := TC_Count + Interfaces.C.size_t(TC_Increment); + end loop; + + + + -- Check that the "-" function with Pointer and ptrdiff_t parameters, + -- that returns a Pointer result, produces correct results, based + -- on the size of the array elements. + + -- Set the pointer to the last element in the char_array, which is a + -- nul char. + Char_Ptr := Ch_Array(Interfaces.C.size_t(Alphabet'Length))'Access; + + if Char_Ptr.all /= Interfaces.C.nul then + Report.Failed("Incorrect initial value for the last " & + "Ch_Array value"); + end if; + + Min_size_t := 1; + Max_size_t := Interfaces.C.size_t(Alphabet'Length); + + for i in reverse Min_size_t..Max_size_t loop + + -- Subtract 1 from the pointer; it should now point to the previous + -- element in the array. + Char_Ptr := Char_Ptr - 1; + + if Char_Ptr.all /= Ch_Array(i-1) then + Report.Failed("Incorrect value returned following use " & + "of the function '-' with char element values, " & + "array position : " & Integer'Image(Integer(i-1))); + if not TC_Verbose then + exit; + end if; + end if; + end loop; + + Array_Ptr := Array_of_Arrays(Max_Array_Size)'Access; + TC_Count := Max_Array_Size; + TC_Increment := 3; + while TC_Count > Min_Array_Size+Interfaces.C.size_t(TC_Increment) loop + + -- Decrement the pointer by 3. + Array_Ptr := Array_Pointers."-"(Array_Ptr, Right => 3); + + if Array_Ptr.all /= + Array_of_Arrays(TC_Count - Interfaces.C.size_t(TC_Increment)) + then + Report.Failed("Incorrect value returned following use " & + "of the function -, decrementing by " & + Integer'Image(Integer(TC_Increment)) & + ", array position : " & + Integer'Image(Integer(TC_Count-3))); + if not TC_Verbose then + exit; + end if; + end if; + + TC_Count := TC_Count - Interfaces.C.size_t(TC_Increment); + end loop; + + + + -- Check that the "-" function with two Pointer parameters, that + -- returns a ptrdiff_t type result, produces correct results, + -- based on the size of the array elements. + + TC_ptrdiff_t := 9; + if Char_Pointers."-"(Left => End_Char_Ptr, + Right => Start_Char_Ptr) /= TC_ptrdiff_t + then + Report.Failed("Incorrect result from pointer-pointer " & + "subtraction - 1"); + end if; + + Start_Char_Ptr := Ch_Array(1)'Access; + End_Char_Ptr := Ch_Array(25)'Access; + + TC_ptrdiff_t := 24; + if Char_Pointers."-"(End_Char_Ptr, + Right => Start_Char_Ptr) /= TC_ptrdiff_t + then + Report.Failed("Incorrect result from pointer-pointer " & + "subtraction - 2"); + end if; + + TC_ptrdiff_t := 9; + if Array_Pointers."-"(End_Array_Ptr, + Start_Array_Ptr) /= TC_ptrdiff_t + then + Report.Failed("Incorrect result from pointer-pointer " & + "subtraction - 3"); + end if; + + Start_Array_Ptr := Array_of_Arrays(Min_Array_Size)'Access; + End_Array_Ptr := Array_of_Arrays(Max_Array_Size)'Access; + + TC_ptrdiff_t := Interfaces.C.ptrdiff_t(Max_Array_Size) - + Interfaces.C.ptrdiff_t(Min_Array_Size); + if End_Array_Ptr - Start_Array_Ptr /= TC_ptrdiff_t then + Report.Failed("Incorrect result from pointer-pointer " & + "subtraction - 4"); + end if; + + + + -- Check that the Increment procedure produces correct results, + -- based upon the size of the array elements. + + Short_Ptr := Short_Array(0)'Access; + + for i in Min_Array_Size + 1 .. Max_Array_Size loop + -- Increment the value of the Pointer; it should now point + -- to the next element in the array. + Increment(Ref => Short_Ptr); + + if Short_Ptr.all /= Short_Array(i) then + Report.Failed("Incorrect value returned following use " & + "of the Procedure Increment on pointer to an " & + "array of short values, array position : " & + Integer'Image(Integer(i))); + if not TC_Verbose then + exit; + end if; + end if; + end loop; + + Array_Ptr := Array_of_Arrays(0)'Access; + + for i in Min_Array_Size + 1 .. Max_Array_Size loop + -- Increment the value of the Pointer; it should now point + -- to the next element in the array. + Increment(Array_Ptr); + + if Array_Ptr.all /= Array_of_Arrays(i) then + Report.Failed("Incorrect value returned following use " & + "of the Procedure Increment on an array of " & + "arrays, array position : " & + Integer'Image(Integer(i))); + if not TC_Verbose then + exit; + end if; + end if; + end loop; + + + -- Check that the Decrement procedure produces correct results, + -- based upon the size of the array elements. + + Short_Ptr := Short_Array(Max_Array_Size)'Access; + + for i in reverse Min_Array_Size .. Max_Array_Size - 1 loop + -- Decrement the value of the Pointer; it should now point + -- to the previous element in the array. + Decrement(Ref => Short_Ptr); + + if Short_Ptr.all /= Short_Array(i) then + Report.Failed("Incorrect value returned following use " & + "of the Procedure Decrement on pointer to an " & + "array of short values, array position : " & + Integer'Image(Integer(i))); + if not TC_Verbose then + exit; + end if; + end if; + end loop; + + Array_Ptr := Array_of_Arrays(Max_Array_Size)'Access; + + for i in reverse Min_Array_Size .. Max_Array_Size - 1 loop + -- Decrement the value of the Pointer; it should now point + -- to the previous array element. + Decrement(Array_Ptr); + + if Array_Ptr.all /= Array_of_Arrays(i) then + Report.Failed("Incorrect value returned following use " & + "of the Procedure Decrement on an array of " & + "arrays, array position : " & + Integer'Image(Integer(i))); + if not TC_Verbose then + exit; + end if; + end if; + end loop; + + + + -- Check that each of the "+" and "-" functions above will + -- propagate Pointer_Error if a Pointer parameter is null. + + begin + Short_Ptr := null; + Short_Ptr := Short_Ptr + 4; + Report.Failed("Pointer_Error not raised by Function + when " & + "the Pointer parameter is null"); + if Short_Ptr /= null then -- To avoid optimization. + Report.Comment("This should never be printed"); + end if; + exception + when Short_Pointers.Pointer_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by Function + " & + "when the Pointer parameter is null"); + end; + + + begin + Char_Ptr := null; + Char_Ptr := Char_Ptr - 1; + Report.Failed("Pointer_Error not raised by Function - when " & + "the Pointer parameter is null"); + if Char_Ptr /= null then -- To avoid optimization. + Report.Comment("This should never be printed"); + end if; + exception + when Char_Pointers.Pointer_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by Function - " & + "when the Pointer parameter is null"); + end; + + + begin + Array_Ptr := null; + Decrement(Array_Ptr); + Report.Failed("Pointer_Error not raised by Procedure Decrement " & + "when the Pointer parameter is null"); + if Array_Ptr /= null then -- To avoid optimization. + Report.Comment("This should never be printed"); + end if; + exception + when Array_Pointers.Pointer_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by Procedure " & + "Decrement when the Pointer parameter is null"); + end; + + + exception + when The_Error : others => + Report.Failed ("The following exception was raised in the " & + "Test_Block: " & Exception_Name(The_Error)); + end Test_Block; + + Report.Result; + +end CXB3015; diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb3016.a b/gcc/testsuite/ada/acats/tests/cxb/cxb3016.a new file mode 100644 index 000000000..362a062ad --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb3016.a @@ -0,0 +1,516 @@ +-- CXB3016.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 function Virtual_Length returns the number of elements +-- in the array referenced by the Pointer parameter Ref, up to (but +-- not including) the (first) instance of the element specified in +-- the Terminator parameter. +-- +-- Check that the procedure Copy_Terminated_Array copies the array of +-- elements referenced by Pointer parameter Source, into the array +-- pointed to by parameter Target, based on which of the following +-- two scenarios occurs first: +-- 1) copying the Terminator element, or +-- 2) copying the number of elements specified in parameter Limit. +-- +-- Check that procedure Copy_Terminated_Array will propagate +-- Dereference_Error if either the Source or Target parameter is null. +-- +-- Check that procedure Copy_Array will copy an array of elements +-- of length specified in parameter Length, referenced by the +-- Pointer parameter Source, into the array pointed to by parameter +-- Target. +-- +-- Check that procedure Copy_Array will propagate Dereference_Error +-- if either the Source or Target parameter is null. +-- +-- TEST DESCRIPTION: +-- This test checks that the function Virtual_Length and the procedures +-- Copy_Terminated_Array and Copy_Array in the generic package +-- Interfaces.C.Pointers will allow the user to manipulate arrays of +-- char and short values through the pointers that reference the +-- arrays. +-- +-- Package Interfaces.C.Pointers is instantiated twice, once for +-- short values and once for chars. Pointers from each instantiated +-- package are then used to reference arrays of the appropriate +-- element type. The subprograms under test are used to determine the +-- length, and to copy, either portions or the entire content of the +-- arrays. The results of these operations are then compared against +-- expected results. +-- +-- The propagation of Dereference_Error is checked for when either +-- of the two procedures is supplied with a null Pointer parameter. +-- +-- This test assumes that the following characters are all included +-- in the implementation defined type Interfaces.C.char: +-- ' ', and 'a'..'z'. +-- +-- APPLICABILITY CRITERIA: +-- This test is applicable to all implementations that provide +-- packages Interfaces.C, Interfaces.C.Strings, and +-- Interfaces.C.Pointers. If an implementation provides these packages, +-- this test must compile, execute, and report "PASSED". +-- +-- +-- CHANGE HISTORY: +-- 01 Feb 96 SAIC Initial release for 2.1 +-- 13 May 96 SAIC Incorporated reviewer comments for ACVC 2.1. +-- 26 Oct 96 SAIC Incorporated reviewer comments. +-- 26 Feb 97 PWB.CTA Moved code using null pointer to avoid errors +--! + +with Report; +with Ada.Exceptions; +with Interfaces.C; -- N/A => ERROR +with Interfaces.C.Pointers; -- N/A => ERROR +with Interfaces.C.Strings; -- N/A => ERROR + +procedure CXB3016 is +begin + + Report.Test ("CXB3016", "Check that subprograms Virtual_Length, " & + "Copy_Terminated_Array, and Copy_Array " & + "produce correct results"); + + Test_Block: + declare + + use Ada.Exceptions; + use Interfaces.C.Strings; + + use type Interfaces.C.char, + Interfaces.C.char_array, + Interfaces.C.ptrdiff_t, + Interfaces.C.short, + Interfaces.C.size_t; + + TC_char : Interfaces.C.char := 'a'; + TC_ptrdiff_t : Interfaces.C.ptrdiff_t; + TC_Short : Interfaces.C.short := 0; + Min_Array_Size : Interfaces.C.size_t := 0; + Max_Array_Size : Interfaces.C.size_t := 20; + Short_Terminator : Interfaces.C.short := Interfaces.C.short'Last; + Alphabet : constant String := "abcdefghijklmnopqrstuvwxyz"; + Blank_String : constant String := " "; + + type Short_Array_Type is + array (Interfaces.C.size_t range <>) of aliased Interfaces.C.short; + + Ch_Array : Interfaces.C.char_array + (0..Interfaces.C.size_t(Alphabet'Length)) := + Interfaces.C.To_C(Alphabet, True); + + TC_Ch_Array : Interfaces.C.char_array + (0..Interfaces.C.size_t(Blank_String'Length)) := + Interfaces.C.To_C(Blank_String, True); + + Short_Array : Short_Array_Type(Min_Array_Size..Max_Array_Size); + TC_Short_Array : Short_Array_Type(Min_Array_Size..Max_Array_Size); + + + package Char_Pointers is new + Interfaces.C.Pointers (Index => Interfaces.C.size_t, + Element => Interfaces.C.char, + Element_Array => Interfaces.C.char_array, + Default_Terminator => Interfaces.C.nul); + + package Short_Pointers is new + Interfaces.C.Pointers (Index => Interfaces.C.size_t, + Element => Interfaces.C.short, + Element_Array => Short_Array_Type, + Default_Terminator => Short_Terminator); + + use Short_Pointers, Char_Pointers; + + Short_Ptr : Short_Pointers.Pointer := Short_Array(0)'Access; + TC_Short_Ptr : Short_Pointers.Pointer := TC_Short_Array(0)'Access; + Char_Ptr : Char_Pointers.Pointer := Ch_Array(0)'Access; + TC_Char_Ptr : Char_Pointers.Pointer := TC_Ch_Array(0)'Access; + + begin + + -- Provide initial values for the array that holds short int values. + + for i in Min_Array_Size..Max_Array_Size loop + Short_Array(i) := Interfaces.C.short(i); + TC_Short_Array(i) := 100; + end loop; + + -- Set the final element of the short array object to be the "terminator" + -- element used in the instantiation above. + + Short_Array(Max_Array_Size) := Short_Terminator; + + -- Check starting pointer positions. + + if Short_Ptr.all /= 0 or + Char_Ptr.all /= Ch_Array(0) + then + Report.Failed("Incorrect initial value for the first " & + "Char_Array or Short_Array values"); + end if; + + + + -- Check that function Virtual_Length returns the number of elements + -- in the array referenced by the Pointer parameter Ref, up to (but + -- not including) the (first) instance of the element specified in + -- the Terminator parameter. + + TC_char := 'j'; + + TC_ptrdiff_t := Char_Pointers.Virtual_Length(Ref => Char_Ptr, + Terminator => TC_char); + if TC_ptrdiff_t /= 9 then + Report.Failed("Incorrect result from function Virtual_Length " & + "with Char_ptr parameter - 1"); + end if; + + TC_char := Interfaces.C.nul; + + TC_ptrdiff_t := Char_Pointers.Virtual_Length(Char_Ptr, + Terminator => TC_char); + if TC_ptrdiff_t /= Interfaces.C.ptrdiff_t(Alphabet'Length) then + Report.Failed("Incorrect result from function Virtual_Length " & + "with Char_ptr parameter - 2"); + end if; + + TC_Short := 10; + + TC_ptrdiff_t := Short_Pointers.Virtual_Length(Short_Ptr, TC_Short); + + if TC_ptrdiff_t /= 10 then + Report.Failed("Incorrect result from function Virtual_Length " & + "with Short_ptr parameter - 1"); + end if; + + -- Replace an element of the Short_Array with the element used as the + -- terminator of the entire array; now there are two occurrences of the + -- terminator element in the array. The call to Virtual_Length should + -- return the number of array elements prior to the first terminator. + + Short_Array(5) := Short_Terminator; + + if Short_Pointers.Virtual_Length(Short_Ptr, Short_Terminator) /= 5 + then + Report.Failed("Incorrect result from function Virtual_Length " & + "with Short_ptr parameter - 2"); + end if; + + + + -- Check that the procedure Copy_Terminated_Array copies the array of + -- elements referenced by Pointer parameter Source, into the array + -- pointed to by parameter Target, based on which of the following + -- two scenarios occurs first: + -- 1) copying the Terminator element, or + -- 2) copying the number of elements specified in parameter Limit. + -- Note: Terminator element must be copied to Target, as well as + -- all array elements prior to the terminator element. + + if TC_Ch_Array = Ch_Array then + Report.Failed("The two char arrays are equivalent prior to the " & + "call to Copy_Terminated_Array - 1"); + end if; + + + -- Case 1: Copying the Terminator Element. (Default terminator) + + Char_Pointers.Copy_Terminated_Array(Source => Char_Ptr, + Target => TC_Char_Ptr); + + if TC_Ch_Array /= Ch_Array then + Report.Failed("The two char arrays are not equal following the " & + "call to Copy_Terminated_Array, case of copying " & + "the Terminator Element, using default terminator"); + end if; + + -- Reset the Target Pointer array. + + TC_Ch_Array := Interfaces.C.To_C(Blank_String, True); + TC_Char_Ptr := TC_Ch_Array(0)'Access; + + if TC_Ch_Array = Ch_Array then + Report.Failed("The two char arrays are equivalent prior to the " & + "call to Copy_Terminated_Array - 2"); + end if; + + + -- Case 2: Copying the Terminator Element. (Non-Default terminator) + + TC_char := 'b'; -- Second char in char_array pointed to by Char_Ptr + Char_Pointers.Copy_Terminated_Array(Source => Char_Ptr, + Target => TC_Char_Ptr, + Terminator => TC_char); + + if TC_Ch_Array(0) /= Ch_Array(0) or -- Initial value modified. + TC_Ch_Array(1) /= Ch_Array(1) or -- Initial value modified. + TC_Ch_Array(2) = Ch_Array(2) or -- Initial value not modified. + TC_Ch_Array(5) = Ch_Array(5) or -- Initial value not modified. + TC_Ch_Array(15) = Ch_Array(15) or -- Initial value not modified. + TC_Ch_Array(25) = Ch_Array(25) -- Initial value not modified. + then + Report.Failed("The appropriate portions of the two char arrays " & + "are not equal following the call to " & + "Copy_Terminated_Array, case of copying the " & + "Terminator Element, using non-default terminator"); + end if; + + + if TC_Short_Array = Short_Array then + Report.Failed("The two short int arrays are equivalent prior " & + "to the call to Copy_Terminated_Array - 1"); + end if; + + Short_Pointers.Copy_Terminated_Array(Source => Short_Ptr, + Target => TC_Short_Ptr, + Terminator => 2); + + if TC_Short_Array(0) /= Short_Array(0) or + TC_Short_Array(1) /= Short_Array(1) or + TC_Short_Array(2) /= Short_Array(2) or + TC_Short_Array(3) /= 100 -- Initial value not modified. + then + Report.Failed("The appropriate portions of the two short int " & + "arrays are not equal following the call to " & + "Copy_Terminated_Array, case of copying the " & + "Terminator Element, using non-default terminator"); + end if; + + + -- Case 3: Copying the number of elements specified in parameter Limit. + + if TC_Short_Array = Short_Array then + Report.Failed("The two short int arrays are equivalent prior " & + "to the call to Copy_Terminated_Array - 2"); + end if; + + TC_ptrdiff_t := 5; + + Short_Pointers.Copy_Terminated_Array(Source => Short_Ptr, + Target => TC_Short_Ptr, + Limit => TC_ptrdiff_t, + Terminator => Short_Terminator); + + if TC_Short_Array(0) /= Short_Array(0) or + TC_Short_Array(1) /= Short_Array(1) or + TC_Short_Array(2) /= Short_Array(2) or + TC_Short_Array(3) /= Short_Array(3) or + TC_Short_Array(4) /= Short_Array(4) or + TC_Short_Array(5) /= 100 -- Initial value not modified. + then + Report.Failed("The appropriate portions of the two Short arrays " & + "are not equal following the call to " & + "Copy_Terminated_Array, case of copying the number " & + "of elements specified in parameter Limit"); + end if; + + + -- Case 4: Copying the number of elements specified in parameter Limit, + -- which also happens to be the number of elements up to and + -- including the first terminator. + + -- Reset initial values for the array that holds short int values. + + for i in Min_Array_Size..Max_Array_Size loop + Short_Array(i) := Interfaces.C.short(i); + TC_Short_Array(i) := 100; + end loop; + + if TC_Short_Array = Short_Array then + Report.Failed("The two short int arrays are equivalent prior " & + "to the call to Copy_Terminated_Array - 3"); + end if; + + TC_ptrdiff_t := 3; -- Specifies three elements to be copied. + Short_Terminator := 2; -- Value held in Short_Array third element, + -- will serve as the "terminator" element. + + Short_Pointers.Copy_Terminated_Array(Source => Short_Ptr, + Target => TC_Short_Ptr, + Limit => TC_ptrdiff_t, + Terminator => Short_Terminator); + + if TC_Short_Array(0) /= Short_Array(0) or -- First element copied. + TC_Short_Array(1) /= Short_Array(1) or -- Second element copied. + TC_Short_Array(2) /= Short_Array(2) or -- Third element copied. + TC_Short_Array(3) /= 100 -- Initial value of fourth element + then -- not modified. + Report.Failed("The appropriate portions of the two Short arrays " & + "are not equal following the call to " & + "Copy_Terminated_Array, case of copying the number " & + "of elements specified in parameter " & + "Limit, which also happens to be the number of " & + "elements up to and including the first terminator"); + end if; + + + + -- Check that procedure Copy_Terminated_Array will propagate + -- Dereference_Error if either the Source or Target parameter is null. + + Char_Ptr := null; + begin + Char_Pointers.Copy_Terminated_Array(Char_Ptr, TC_Char_Ptr); + Report.Failed("Dereference_Error not raised by call to " & + "Copy_Terminated_Array with null Source parameter"); + if TC_Char_Ptr = null then -- To avoid optimization. + Report.Comment("This should never be printed"); + end if; + exception + when Dereference_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by call to " & + "Copy_Terminated_Array with null Source parameter"); + end; + + TC_Short_Ptr := null; + begin + Short_Pointers.Copy_Terminated_Array(Short_Ptr, TC_Short_Ptr); + Report.Failed("Dereference_Error not raised by call to " & + "Copy_Terminated_Array with null Target parameter"); + if Short_Ptr = null then -- To avoid optimization. + Report.Comment("This should never be printed"); + end if; + exception + when Dereference_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by call to " & + "Copy_Terminated_Array with null Target parameter"); + end; + + + + -- Check that the procedure Copy_Array will copy the array of + -- elements of length specified in parameter Length, referenced by + -- the Pointer parameter Source, into the array pointed to by + -- parameter Target. + + -- Reinitialize Target arrays prior to test cases below. + + TC_Ch_Array := Interfaces.C.To_C(Blank_String, True); + + for i in Min_Array_Size..Max_Array_Size loop + TC_Short_Array(i) := 100; + end loop; + + Char_Ptr := Ch_Array(0)'Access; + TC_Char_Ptr := TC_Ch_Array(0)'Access; + Short_Ptr := Short_Array(0)'Access; + TC_Short_Ptr := TC_Short_Array(0)'Access; + + TC_ptrdiff_t := 4; + + Char_Pointers.Copy_Array(Source => Char_Ptr, + Target => TC_Char_Ptr, + Length => TC_ptrdiff_t); + + if TC_Ch_Array(0) /= Ch_Array(0) or + TC_Ch_Array(1) /= Ch_Array(1) or + TC_Ch_Array(2) /= Ch_Array(2) or + TC_Ch_Array(3) /= Ch_Array(3) or + TC_Ch_Array(4) = Ch_Array(4) + then + Report.Failed("Incorrect result from Copy_Array when using " & + "char pointer arguments, partial array copied"); + end if; + + + TC_ptrdiff_t := Interfaces.C.ptrdiff_t(Max_Array_Size) + 1; + + Short_Pointers.Copy_Array(Short_Ptr, TC_Short_Ptr, TC_ptrdiff_t); + + if TC_Short_Array /= Short_Array then + Report.Failed("Incorrect result from Copy_Array when using Short " & + "pointer arguments, entire array copied"); + end if; + + + + -- Check that procedure Copy_Array will propagate Dereference_Error + -- if either the Source or Target parameter is null. + + Char_Ptr := null; + begin + Char_Pointers.Copy_Array(Char_Ptr, TC_Char_Ptr, TC_ptrdiff_t); + Report.Failed("Dereference_Error not raised by call to " & + "Copy_Array with null Source parameter"); + if TC_Char_Ptr = null then -- To avoid optimization. + Report.Comment("This should never be printed"); + end if; + exception + when Dereference_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by call to " & + "Copy_Array with null Source parameter"); + end; + + TC_Short_Ptr := null; + begin + Short_Pointers.Copy_Array(Short_Ptr, TC_Short_Ptr, TC_ptrdiff_t); + Report.Failed("Dereference_Error not raised by call to " & + "Copy_Array with null Target parameter"); + if Short_Ptr = null then -- To avoid optimization. + Report.Comment("This should never be printed"); + end if; + exception + when Dereference_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by call to " & + "Copy_Array with null Target parameter"); + end; + + + -- Check that function Virtual_Length will propagate Dereference_Error + -- if the Source parameter is null. + + Char_Ptr := null; + begin + TC_ptrdiff_t := Char_Pointers.Virtual_Length(Char_Ptr, + Terminator => TC_char); + Report.Failed("Dereference_Error not raised by call to " & + "Virtual_Length with null Source parameter"); + if TC_ptrdiff_t = 100 then -- To avoid optimization. + Report.Comment("This should never be printed"); + end if; + exception + when Dereference_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by call to " & + "Virtual_Length with null Source parameter"); + end; + + + exception + when The_Error : others => + Report.Failed ("The following exception was raised in the " & + "Test_Block: " & Exception_Name(The_Error)); + end Test_Block; + + Report.Result; + +end CXB3016; diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb4001.a b/gcc/testsuite/ada/acats/tests/cxb/cxb4001.a new file mode 100644 index 000000000..0c9ab1a62 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb4001.a @@ -0,0 +1,230 @@ +-- CXB4001.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 the specifications of the package Interfaces.COBOL +-- are available for use +-- +-- TEST DESCRIPTION: +-- This test verifies that the type and the subprograms specified for +-- the interface are present. +-- +-- APPLICABILITY CRITERIA: +-- This test is applicable to all implementations that provide +-- package Interfaces.COBOL. If an implementation provides +-- package Interfaces.COBOL, this test must compile, execute, and +-- report "PASSED". +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 15 Nov 95 SAIC Corrected visibility errors for ACVC 2.0.1. +-- 28 Feb 96 SAIC Added applicability criteria. +-- 27 Oct 96 SAIC Incorporated reviewer comments. +-- 01 DEC 97 EDS Change "To_Comp" to "To_Binary". +--! + +with Report; +with Interfaces.COBOL; -- N/A => ERROR + +procedure CXB4001 is + + package COBOL renames Interfaces.COBOL; + use type COBOL.Byte; + use type COBOL.Decimal_Element; + +begin + + Report.Test ("CXB4001", "Check the specification of Interfaces.COBOL"); + + + declare -- encapsulate the test + + -- Types and operations for internal data representations + + TST_Floating : COBOL.Floating; + TST_Long_Floating : COBOL.Long_Floating; + + TST_Binary : COBOL.Binary; + TST_Long_Binary : COBOL.Long_Binary; + + TST_Max_Digits_Binary : constant := COBOL.Max_Digits_Binary; + TST_Max_Digits_Long_Binary : constant := COBOL.Max_Digits_Long_Binary; + + TST_Decimal_Element : COBOL.Decimal_Element; + + TST_Packed_Decimal : COBOL.Packed_Decimal (1..5) := + (others => COBOL.Decimal_Element'First); + + -- initialize it so it can reasonably be used later + TST_COBOL_Character : COBOL.COBOL_Character := + COBOL.COBOL_Character'First; + + TST_Ada_To_COBOL : COBOL.COBOL_Character := + COBOL.Ada_To_COBOL (Character'First); + + TST_COBOL_To_Ada : Character := + COBOL.COBOL_To_Ada (COBOL.COBOL_Character'First); + + -- assignment to make sure it is an array of COBOL_Character + TST_Alphanumeric : COBOL.Alphanumeric (1..5) := + (others => TST_COBOL_Character); + + + -- assignment to make sure it is an array of COBOL_Character + TST_Numeric : COBOL.Numeric (1..5) := (others => TST_COBOL_Character); + + + procedure Collect_All_Calls is + + CAC_Alphanumeric : COBOL.Alphanumeric(1..5) := + COBOL.To_COBOL("abcde"); + CAC_String : String (1..5) := "vwxyz"; + CAC_Natural : natural := 0; + + begin + + CAC_Alphanumeric := COBOL.To_COBOL (CAC_String); + CAC_String := COBOL.To_Ada (CAC_Alphanumeric); + + COBOL.To_COBOL (CAC_String, CAC_Alphanumeric, CAC_Natural); + COBOL.To_Ada (CAC_Alphanumeric, CAC_String, CAC_Natural); + + raise COBOL.Conversion_Error; + + end Collect_All_Calls; + + + + -- Formats for COBOL data representations + + TST_Unsigned : COBOL.Display_Format := COBOL.Unsigned; + TST_Leading_Separate : COBOL.Display_Format := COBOL.Leading_Separate; + TST_Trailing_Separate : COBOL.Display_Format := COBOL.Trailing_Separate; + TST_Leading_Nonseparate : COBOL.Display_Format := + COBOL.Leading_Nonseparate; + TST_Trailing_Nonseparate : COBOL.Display_Format := + COBOL.Trailing_Nonseparate; + + + TST_High_Order_First : COBOL.Binary_Format := COBOL.High_Order_First; + TST_Low_Order_First : COBOL.Binary_Format := COBOL.Low_Order_First; + TST_Native_Binary : COBOL.Binary_Format := COBOL.Native_Binary; + + + TST_Packed_Unsigned : COBOL.Packed_Format := COBOL.Packed_Unsigned; + TST_Packed_Signed : COBOL.Packed_Format := COBOL.Packed_Signed; + + + -- Types for external representation of COBOL binary data + + TST_Byte_Array : COBOL.Byte_Array(1..5) := (others => COBOL.Byte'First); + + -- Now instantiate one version of the generic + -- + type bx4001_Decimal is delta 0.1 digits 5; + package bx4001_conv is new COBOL.Decimal_Conversions (bx4001_Decimal); + + procedure Collect_All_Generic_Calls is + CAGC_natural : natural; + CAGC_Display_Format : COBOL.Display_Format; + CAGC_Boolean : Boolean; + CAGC_Numeric : COBOL.Numeric(1..5); + CAGC_Num : bx4001_Decimal; + CAGC_Packed_Decimal : COBOL.Packed_Decimal (1..5); + CAGC_Packed_Format : COBOL.Packed_Format; + CAGC_Byte_Array : COBOL.Byte_Array (1..5); + CAGC_Binary_Format : COBOL.Binary_Format; + CAGC_Binary : COBOL.Binary; + CAGC_Long_Binary : COBOL.Long_Binary; + begin + + -- Display Formats: data values are represented as Numeric + + CAGC_Boolean := bx4001_conv.Valid (CAGC_Numeric, CAGC_Display_Format); + CAGC_Natural := bx4001_conv.Length (CAGC_Display_Format); + + CAGC_Num := bx4001_conv.To_Decimal + (CAGC_Numeric, CAGC_Display_Format); + CAGC_Numeric := bx4001_conv.To_Display + (CAGC_Num, CAGC_Display_Format); + + + -- Packed Formats: data values are represented as Packed_Decimal + + CAGC_Boolean := bx4001_conv.Valid + (CAGC_Packed_Decimal, CAGC_Packed_Format); + + CAGC_Natural := bx4001_conv.Length (CAGC_Packed_Format); + + CAGC_Num := bx4001_conv.To_Decimal + (CAGC_Packed_Decimal, CAGC_Packed_Format); + + CAGC_Packed_Decimal := bx4001_conv.To_Packed + (CAGC_Num, CAGC_Packed_Format); + + + -- Binary Formats: external data values are represented as + -- Byte_Array + + CAGC_Boolean := bx4001_conv.Valid + (CAGC_Byte_Array, CAGC_Binary_Format); + + CAGC_Natural := bx4001_conv.Length (CAGC_Binary_Format); + CAGC_Num := bx4001_conv.To_Decimal + (CAGC_Byte_Array, CAGC_Binary_Format); + + CAGC_Byte_Array := bx4001_conv.To_Binary (CAGC_Num, CAGC_Binary_Format); + + + -- Internal Binary formats: data values are of type + -- Binary/Long_Binary + + CAGC_Num := bx4001_conv.To_Decimal (CAGC_Binary); + CAGC_Num := bx4001_conv.To_Decimal (CAGC_Long_Binary); + + CAGC_Binary := bx4001_conv.To_Binary (CAGC_Num); + CAGC_Long_Binary := bx4001_conv.To_Long_Binary (CAGC_Num); + + + end Collect_All_Generic_Calls; + + + begin -- encapsulation + + if COBOL.Byte'First /= 0 or + COBOL.Byte'Last /= (2 ** COBOL.COBOL_Character'Size) - 1 then + Report.Failed ("Byte is incorrectly defined"); + end if; + + if COBOL.Decimal_Element'First /= 0 then + Report.Failed ("Decimal_Element is incorrectly defined"); + end if; + + end; -- encapsulation + + Report.Result; + +end CXB4001; diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb4002.a b/gcc/testsuite/ada/acats/tests/cxb/cxb4002.a new file mode 100644 index 000000000..e3934a5ef --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb4002.a @@ -0,0 +1,308 @@ +-- CXB4002.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 the procedure To_COBOL converts the character elements +-- of the String parameter Item into COBOL_Character elements of the +-- Alphanumeric type parameter Target, using the Ada_to_COBOL mapping +-- as the basis of conversion. +-- Check that the parameter Last contains the index of the last element +-- of parameter Target that was assigned by To_COBOL. +-- +-- Check that Constraint_Error is propagated by procedure To_COBOL +-- when the length of String parameter Item exceeds the length of +-- Alphanumeric parameter Target. +-- +-- Check that the procedure To_Ada converts the COBOL_Character +-- elements of the Alphanumeric parameter Item into Character elements +-- of the String parameter Target, using the COBOL_to_Ada mapping array +-- as the basis of conversion. +-- Check that the parameter Last contains the index of the last element +-- of parameter Target that was assigned by To_Ada. +-- +-- Check that Constraint_Error is propagated by procedure To_Ada when +-- the length of Alphanumeric parameter Item exceeds the length of +-- String parameter Target. +-- +-- TEST DESCRIPTION: +-- This test checks that the procedures To_COBOL and To_Ada produce +-- the correct results, based on a variety of parameter input values. +-- +-- In the first series of subtests, the Out parameter results of +-- procedure To_COBOL are compared against expected results, +-- which includes (in the parameter Last) the index in Target of the +-- last element assigned. The situation where procedure To_COBOL raises +-- Constraint_Error (when Item'Length exceeds Target'Length) is also +-- verified. +-- +-- In the second series of subtests, the Out parameter results of +-- procedure To_Ada are verified, in a similar manner as is done for +-- procedure To_COBOL. The case of procedure To_Ada raising +-- Constraint_Error is also verified. +-- +-- This test assumes that the following characters are all included +-- in the implementation defined type Interfaces.COBOL.COBOL_Character: +-- ' ', 'a'..'z', 'A'..'Z', '0'..'9', '*', '$', '-', '_', and '#'. +-- +-- APPLICABILITY CRITERIA: +-- This test is applicable to all implementations that provide +-- package Interfaces.COBOL. If an implementation provides +-- package Interfaces.COBOL, this test must compile, execute, and +-- report "PASSED". +-- +-- +-- CHANGE HISTORY: +-- 12 Jan 96 SAIC Initial prerelease version. +-- 30 May 96 SAIC Added applicability criteria for ACVC 2.1. +-- 27 Oct 96 SAIC Incorporated reviewer comments. +-- +--! + +with Report; +with Ada.Strings.Bounded; +with Ada.Strings.Unbounded; +with Interfaces.COBOL; -- N/A => ERROR + +procedure CXB4002 is +begin + + Report.Test ("CXB4002", "Check that the procedures To_COBOL and " & + "To_Ada produce correct results"); + + Test_Block: + declare + + package Bnd is new Ada.Strings.Bounded.Generic_Bounded_Length(10); + package Unb renames Ada.Strings.Unbounded; + + use Interfaces; + use Bnd, Unb; + use type Interfaces.COBOL.Alphanumeric; + + + Alphanumeric_1 : COBOL.Alphanumeric(1..1) := " "; + Alphanumeric_5 : COBOL.Alphanumeric(1..5) := " "; + Alphanumeric_10 : COBOL.Alphanumeric(1..10) := " "; + Alphanumeric_20 : COBOL.Alphanumeric(1..20) := " "; + TC_Alphanumeric_1 : COBOL.Alphanumeric(1..1) := "A"; + TC_Alphanumeric_5 : COBOL.Alphanumeric(1..5) := "ab*de"; + TC_Alphanumeric_10 : COBOL.Alphanumeric(1..10) := "$1a2b3C4D5"; + TC_Alphanumeric_20 : COBOL.Alphanumeric(1..20) := "1234-ABCD_6789#fghij"; + + Bnd_String : Bnd.Bounded_String := + Bnd.To_Bounded_String(" "); + TC_Bnd_String : Bounded_String := + To_Bounded_String("$1a2b3C4D5"); + + Unb_String : Unb.Unbounded_String := + Unb.To_Unbounded_String(" "); + TC_Unb_String : Unbounded_String := + To_Unbounded_String("ab*de"); + + String_1 : String(1..1) := " "; + String_5 : String(1..5) := " "; + String_10 : String(1..10) := " "; + String_20 : String(1..20) := " "; + TC_String_1 : String(1..1) := "A"; + TC_String_20 : String(1..20) := "1234-ABCD_6789#fghij"; + + TC_Alphanumeric : constant COBOL.Alphanumeric := ""; -- null array. + TC_String : constant String := ""; -- null string. + TC_Natural : Natural := 0; + + + begin + + -- Check that the procedure To_COBOL converts the character elements + -- of the String parameter Item into COBOL_Character elements of the + -- Alphanumeric type parameter Target, using the Ada_to_COBOL mapping + -- as the basis of conversion. + -- Check that the parameter Last contains the index of the last element + -- of parameter Target that was assigned by To_COBOL. + + COBOL.To_COBOL(Item => TC_String_1, + Target => Alphanumeric_1, + Last => TC_Natural); + + if Alphanumeric_1 /= TC_Alphanumeric_1 or + TC_Natural /= TC_Alphanumeric_1'Length or + TC_Natural /= 1 + then + Report.Failed("Incorrect result from procedure To_COBOL - 1"); + end if; + + COBOL.To_COBOL(To_String(TC_Unb_String), + Target => Alphanumeric_5, + Last => TC_Natural); + + if Alphanumeric_5 /= TC_Alphanumeric_5 or + TC_Natural /= TC_Alphanumeric_5'Length or + TC_Natural /= 5 + then + Report.Failed("Incorrect result from procedure To_COBOL - 2"); + end if; + + COBOL.To_COBOL(To_String(TC_Bnd_String), + Alphanumeric_10, + Last => TC_Natural); + + if Alphanumeric_10 /= TC_Alphanumeric_10 or + TC_Natural /= TC_Alphanumeric_10'Length or + TC_Natural /= 10 + then + Report.Failed("Incorrect result from procedure To_COBOL - 3"); + end if; + + COBOL.To_COBOL(TC_String_20, + Alphanumeric_20, + TC_Natural); + + if Alphanumeric_20 /= TC_Alphanumeric_20 or + TC_Natural /= TC_Alphanumeric_20'Length or + TC_Natural /= 20 + then + Report.Failed("Incorrect result from procedure To_COBOL - 4"); + end if; + + COBOL.To_COBOL(Item => TC_String, -- null string + Target => Alphanumeric_1, + Last => TC_Natural); + + if TC_Natural /= 0 then + Report.Failed("Incorrect result from procedure To_COBOL, value " & + "returned in parameter Last should be zero, since " & + "parameter Item is null array"); + end if; + + + + -- Check that Constraint_Error is propagated by procedure To_COBOL + -- when the length of String parameter Item exceeds the length of + -- Alphanumeric parameter Target. + + begin + + COBOL.To_COBOL(Item => TC_String_20, + Target => Alphanumeric_10, + Last => TC_Natural); + Report.Failed("Constraint_Error not raised by procedure To_COBOL " & + "when Item'Length exceeds Target'Length"); + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by procedure To_COBOL " & + "when Item'Length exceeds Target'Length"); + end; + + + -- Check that the procedure To_Ada converts the COBOL_Character + -- elements of the Alphanumeric parameter Item into Character elements + -- of the String parameter Target, using the COBOL_to_Ada mapping array + -- as the basis of conversion. + -- Check that the parameter Last contains the index of the last element + -- of parameter Target that was assigned by To_Ada. + + COBOL.To_Ada(Item => TC_Alphanumeric_1, + Target => String_1, + Last => TC_Natural); + + if String_1 /= TC_String_1 or + TC_Natural /= TC_String_1'Length or + TC_Natural /= 1 + then + Report.Failed("Incorrect result from procedure To_Ada - 1"); + end if; + + COBOL.To_Ada(TC_Alphanumeric_5, + Target => String_5, + Last => TC_Natural); + + if String_5 /= To_String(TC_Unb_String) or + TC_Natural /= Length(TC_Unb_String) or + TC_Natural /= 5 + then + Report.Failed("Incorrect result from procedure To_Ada - 2"); + end if; + + COBOL.To_Ada(TC_Alphanumeric_10, + String_10, + Last => TC_Natural); + + if String_10 /= To_String(TC_Bnd_String) or + TC_Natural /= Length(TC_Bnd_String) or + TC_Natural /= 10 + then + Report.Failed("Incorrect result from procedure To_Ada - 3"); + end if; + + COBOL.To_Ada(TC_Alphanumeric_20, + String_20, + TC_Natural); + + if String_20 /= TC_String_20 or + TC_Natural /= TC_String_20'Length or + TC_Natural /= 20 + then + Report.Failed("Incorrect result from procedure To_Ada - 4"); + end if; + + COBOL.To_Ada(Item => TC_Alphanumeric, -- null array. + Target => String_20, + Last => TC_Natural); + + if TC_Natural /= 0 then + Report.Failed("Incorrect result from procedure To_Ada, value " & + "returned in parameter Last should be zero, since " & + "parameter Item is null array"); + end if; + + + + -- Check that Constraint_Error is propagated by procedure To_Ada when + -- the length of Alphanumeric parameter Item exceeds the length of + -- String parameter Target. + + begin + + COBOL.To_Ada(Item => TC_Alphanumeric_10, + Target => String_5, + Last => TC_Natural); + Report.Failed("Constraint_Error not raised by procedure To_Ada " & + "when Item'Length exceeds Target'Length"); + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by procedure To_Ada " & + "when Item'Length exceeds Target'Length"); + end; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + +end CXB4002; diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb4003.a b/gcc/testsuite/ada/acats/tests/cxb/cxb4003.a new file mode 100644 index 000000000..609dabc50 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb4003.a @@ -0,0 +1,310 @@ +-- CXB4003.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 function Valid, with the Display_Format parameter +-- set to Unsigned, will return True if Numeric parameter Item +-- comprises one or more decimal digit characters; check that it +-- returns False if the parameter Item is otherwise comprised. +-- +-- Check that function Valid, with Display_Format parameter set to +-- Leading_Separate, will return True if Numeric parameter Item +-- comprises a single occurrence of a Plus_Sign or Minus_Sign +-- character, and then by one or more decimal digit characters; +-- check that it returns False if the parameter Item is otherwise +-- comprised. +-- +-- Check that function Valid, with Display_Format parameter set to +-- Trailing_Separate, will return True if Numeric parameter Item +-- comprises one or more decimal digit characters, and then by a +-- single occurrence of the Plus_Sign or Minus_Sign character; +-- check that it returns False if the parameter Item is otherwise +-- comprised. +-- +-- TEST DESCRIPTION: +-- This test checks that a version of function Valid, from an instance +-- of the generic package Decimal_Conversions, will produce correct +-- results based on the particular Numeric and Display_Format +-- parameters provided. Arrays of both valid and invalid Numeric +-- data items have been created to correspond to a particular +-- value of Display_Format. The result of the function is compared +-- against the expected result for each appropriate combination of +-- Numeric and Display_Format parameter. +-- This test assumes that the following characters are all included +-- in the implementation defined type Interfaces.COBOL.COBOL_Character: +-- ' ', 'A'..'Z', '+', '-', '.', '$'. +-- +-- APPLICABILITY CRITERIA: +-- This test is applicable to all implementations that provide +-- package Interfaces.COBOL. If an implementation provides +-- package Interfaces.COBOL, this test must compile, execute, and +-- report "PASSED". +-- +-- +-- +-- CHANGE HISTORY: +-- 18 Jan 96 SAIC Initial version for 2.1. +-- 30 May 96 SAIC Incorporated reviewer comments for ACVC 2.1. +-- 27 Oct 96 SAIC Incorporated reviewer comments. +-- +--! + +with Report; +with Ada.Exceptions; +with Interfaces.COBOL; -- N/A => ERROR + +procedure CXB4003 is +begin + + Report.Test ("CXB4003", "Check that function Valid, with various " & + "Display_Format parameters, produces correct " & + "results"); + + Test_Block: + declare + + use Interfaces; + use Ada.Exceptions; + + type A_Numeric_Type is delta 0.01 digits 16; + type Numeric_Access is access COBOL.Numeric; + type Numeric_Items_Type is array(Integer range <>) of Numeric_Access; + + package Display_Format is + new COBOL.Decimal_Conversions(Num => A_Numeric_Type); + + + Number_Of_Valid_Unsigned_Items : constant := 5; + Number_Of_Invalid_Unsigned_Items : constant := 21; + Number_Of_Valid_Leading_Separate_Items : constant := 5; + Number_Of_Invalid_Leading_Separate_Items : constant := 23; + Number_Of_Valid_Trailing_Separate_Items : constant := 5; + Number_Of_Invalid_Trailing_Separate_Items : constant := 22; + + Valid_Unsigned_Items : + Numeric_Items_Type(1..Number_Of_Valid_Unsigned_Items) := + (new COBOL.Numeric'("0"), + new COBOL.Numeric'("1"), + new COBOL.Numeric'("0000000001"), + new COBOL.Numeric'("1234567890123456"), + new COBOL.Numeric'("0000")); + + Invalid_Unsigned_Items : + Numeric_Items_Type(1..Number_Of_Invalid_Unsigned_Items) := + (new COBOL.Numeric'(" 12345"), + new COBOL.Numeric'(" 12345"), + new COBOL.Numeric'("1234567890 "), + new COBOL.Numeric'("1234567890 "), + new COBOL.Numeric'("1.01"), + new COBOL.Numeric'(".0000000001"), + new COBOL.Numeric'("12345 6"), + new COBOL.Numeric'("MCXVIII"), + new COBOL.Numeric'("15F"), + new COBOL.Numeric'("+12345"), + new COBOL.Numeric'("$12.30"), + new COBOL.Numeric'("1234-"), + new COBOL.Numeric'("12--"), + new COBOL.Numeric'("+12-"), + new COBOL.Numeric'("++99--"), + new COBOL.Numeric'("-1.01"), + new COBOL.Numeric'("(1.01)"), + new COBOL.Numeric'("123,456"), + new COBOL.Numeric'("101."), + new COBOL.Numeric'(""), + new COBOL.Numeric'("1.0000")); + + Valid_Leading_Separate_Items : + Numeric_Items_Type(1..Number_Of_Valid_Leading_Separate_Items) := + (new COBOL.Numeric'("+1000"), + new COBOL.Numeric'("-1"), + new COBOL.Numeric'("-0000000001"), + new COBOL.Numeric'("+1234567890123456"), + new COBOL.Numeric'("-0000")); + + Invalid_Leading_Separate_Items : + Numeric_Items_Type(1..Number_Of_Invalid_Leading_Separate_Items) := + (new COBOL.Numeric'("123456"), + new COBOL.Numeric'(" +12345"), + new COBOL.Numeric'(" +12345"), + new COBOL.Numeric'("- 0000000001"), + new COBOL.Numeric'("1234567890- "), + new COBOL.Numeric'("1234567890+ "), + new COBOL.Numeric'("123-456"), + new COBOL.Numeric'("+15F"), + new COBOL.Numeric'("++123"), + new COBOL.Numeric'("12--"), + new COBOL.Numeric'("+12-"), + new COBOL.Numeric'("+/-12"), + new COBOL.Numeric'("++99--"), + new COBOL.Numeric'("1.01"), + new COBOL.Numeric'("(1.01)"), + new COBOL.Numeric'("+123,456"), + new COBOL.Numeric'("+15FF"), + new COBOL.Numeric'("- 123"), + new COBOL.Numeric'("+$123"), + new COBOL.Numeric'(""), + new COBOL.Numeric'("-"), + new COBOL.Numeric'("-1.01"), + new COBOL.Numeric'("1.0000+")); + + Valid_Trailing_Separate_Items : + Numeric_Items_Type(1..Number_Of_Valid_Trailing_Separate_Items) := + (new COBOL.Numeric'("1001-"), + new COBOL.Numeric'("1+"), + new COBOL.Numeric'("0000000001+"), + new COBOL.Numeric'("1234567890123456-"), + new COBOL.Numeric'("0000-")); + + Invalid_Trailing_Separate_Items : + Numeric_Items_Type(1..Number_Of_Invalid_Trailing_Separate_Items) := + (new COBOL.Numeric'("123456"), + new COBOL.Numeric'("+12345"), + new COBOL.Numeric'("12345 "), + new COBOL.Numeric'("123- "), + new COBOL.Numeric'("123- "), + new COBOL.Numeric'("12345 +"), + new COBOL.Numeric'("12345+ "), + new COBOL.Numeric'("-0000000001"), + new COBOL.Numeric'("123-456"), + new COBOL.Numeric'("12--"), + new COBOL.Numeric'("+12-"), + new COBOL.Numeric'("99+-"), + new COBOL.Numeric'("12+/-"), + new COBOL.Numeric'("12.01-"), + new COBOL.Numeric'("$12.01+"), + new COBOL.Numeric'("(1.01)"), + new COBOL.Numeric'("DM12-"), + new COBOL.Numeric'("123,456+"), + new COBOL.Numeric'(""), + new COBOL.Numeric'("-"), + new COBOL.Numeric'("1.01-"), + new COBOL.Numeric'("+1.0000")); + + begin + + -- Check that function Valid, with the Display_Format parameter + -- set to Unsigned, will return True if Numeric parameter Item + -- comprises one or more decimal digit characters; check that it + -- returns False if the parameter Item is otherwise comprised. + + for i in 1..Number_of_Valid_Unsigned_Items loop + -- Fail if the Item parameter is _NOT_ considered Valid. + if not Display_Format.Valid(Item => Valid_Unsigned_Items(i).all, + Format => COBOL.Unsigned) + then + Report.Failed("Incorrect result from function Valid, with " & + "Format parameter set to Unsigned, for valid " & + "format item number " & Integer'Image(i)); + end if; + end loop; + + + for i in 1..Number_of_Invalid_Unsigned_Items loop + -- Fail if the Item parameter _IS_ considered Valid. + if Display_Format.Valid(Item => Invalid_Unsigned_Items(i).all, + Format => COBOL.Unsigned) + then + Report.Failed("Incorrect result from function Valid, with " & + "Format parameter set to Unsigned, for invalid " & + "format item number " & Integer'Image(i)); + end if; + end loop; + + + + -- Check that function Valid, with Display_Format parameter set to + -- Leading_Separate, will return True if Numeric parameter Item + -- comprises a single occurrence of a Plus_Sign or Minus_Sign + -- character, and then by one or more decimal digit characters; + -- check that it returns False if the parameter Item is otherwise + -- comprised. + + for i in 1..Number_of_Valid_Leading_Separate_Items loop + -- Fail if the Item parameter is _NOT_ considered Valid. + if not Display_Format.Valid(Valid_Leading_Separate_Items(i).all, + Format => COBOL.Leading_Separate) + then + Report.Failed("Incorrect result from function Valid, with " & + "Format parameter set to Leading_Separate, " & + "for valid format item number " & Integer'Image(i)); + end if; + end loop; + + + for i in 1..Number_of_Invalid_Leading_Separate_Items loop + -- Fail if the Item parameter _IS_ considered Valid. + if Display_Format.Valid(Invalid_Leading_Separate_Items(i).all, + Format => COBOL.Leading_Separate) + then + Report.Failed("Incorrect result from function Valid, with " & + "Format parameter set to Leading_Separate, " & + "for invalid format item number " & + Integer'Image(i)); + end if; + end loop; + + + + -- Check that function Valid, with Display_Format parameter set to + -- Trailing_Separate, will return True if Numeric parameter Item + -- comprises one or more decimal digit characters, and then by a + -- single occurrence of the Plus_Sign or Minus_Sign character; + -- check that it returns False if the parameter Item is otherwise + -- comprised. + + for i in 1..Number_of_Valid_Trailing_Separate_Items loop + -- Fail if the Item parameter is _NOT_ considered Valid. + if not Display_Format.Valid(Valid_Trailing_Separate_Items(i).all, + COBOL.Trailing_Separate) + then + Report.Failed("Incorrect result from function Valid, with " & + "Format parameter set to Trailing_Separate, " & + "for valid format item number " & Integer'Image(i)); + end if; + end loop; + + + for i in 1..Number_of_Invalid_Trailing_Separate_Items loop + -- Fail if the Item parameter _IS_ considered Valid. + if Display_Format.Valid(Invalid_Trailing_Separate_Items(i).all, + COBOL.Trailing_Separate) + then + Report.Failed("Incorrect result from function Valid, with " & + "Format parameter set to Trailing_Separate, " & + "for invalid format item number " & + Integer'Image(i)); + end if; + end loop; + + + exception + when The_Error : others => + Report.Failed ("The following exception was raised in the " & + "Test_Block: " & Exception_Name(The_Error)); + end Test_Block; + + Report.Result; + +end CXB4003; diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb4004.a b/gcc/testsuite/ada/acats/tests/cxb/cxb4004.a new file mode 100644 index 000000000..0046c5e7c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb4004.a @@ -0,0 +1,443 @@ +-- CXB4004.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 function Length, with Display_Format parameter, will +-- return the minimal length of a Numeric value that will be required +-- to hold the largest value of type Num represented as Format. +-- +-- Check that function To_Decimal will produce a decimal type Num +-- result that corresponds to parameter Item as represented by +-- parameter Format. +-- +-- Check that function To_Decimal propagates Conversion_Error when +-- the value represented by parameter Item is outside the range of +-- the Decimal_Type Num used to instantiate the package +-- Decimal_Conversions +-- +-- Check that function To_Display returns a Numeric type result that +-- represents Item under the specific Display_Format. +-- +-- Check that function To_Display propagates Conversion_Error when +-- parameter Item is negative and the specified Display_Format +-- parameter is Unsigned. +-- +-- TEST DESCRIPTION: +-- This test checks the results from instantiated versions of three +-- functions within generic package Interfaces.COBOL.Decimal_Conversions. +-- This generic package is instantiated twice, with decimal types having +-- four and ten digits representation. +-- The function Length is validated with the Unsigned, Leading_Separate, +-- and Trailing_Separate Display_Format specifiers. +-- The results of function To_Decimal are verified in cases where it +-- is given a variety of Numeric and Display_Format type parameters. +-- Function To_Decimal is also checked to propagate Conversion_Error +-- when the value represented by parameter Item is outside the range +-- of the type used to instantiate the package. +-- The results of function To_Display are verified in cases where it +-- is given a variety of Num and Display_Format parameters. It is also +-- checked to ensure that it propagates Conversion_Error if parameter +-- Num is negative and the Format parameter is Unsigned. +-- +-- This test assumes that the following characters are all included +-- in the implementation defined type Interfaces.COBOL.COBOL_Character: +-- ' ', '0'..'9', '+', '-', and '.'. +-- +-- APPLICABILITY CRITERIA: +-- This test is applicable to all implementations that provide +-- package Interfaces.COBOL. If an implementation provides +-- package Interfaces.COBOL, this test must compile, execute, and +-- report "PASSED". +-- +-- +-- CHANGE HISTORY: +-- 06 Feb 96 SAIC Initial release for 2.1. +-- 30 May 96 SAIC Incorporated reviewer comments for ACVC 2.1. +-- 27 Oct 96 SAIC Incorporated reviewer comments. +-- +--! + +with Report; +with Interfaces.COBOL; -- N/A => ERROR +with Ada.Exceptions; + +procedure CXB4004 is +begin + + Report.Test ("CXB4004", "Check that the functions Length, To_Decimal, " & + "and To_Display produce correct results"); + + Test_Block: + declare + + use Interfaces; + use Ada.Exceptions; + use type Interfaces.COBOL.Numeric; + + Number_Of_Unsigned_Items : constant := 6; + Number_Of_Leading_Separate_Items : constant := 6; + Number_Of_Trailing_Separate_Items : constant := 6; + Number_Of_Decimal_Items : constant := 9; + + type Decimal_Type_1 is delta 0.01 digits 4; + type Decimal_Type_2 is delta 1.0 digits 10; + type Numeric_Access is access COBOL.Numeric; + type Numeric_Items_Type is array(Integer range <>) of Numeric_Access; + + Correct_Result : Boolean := False; + TC_Num_1 : Decimal_Type_1 := 0.0; + TC_Num_2 : Decimal_Type_2 := 0.0; + + package Package_1 is new COBOL.Decimal_Conversions(Decimal_Type_1); + package Package_2 is new COBOL.Decimal_Conversions(Decimal_Type_2); + + + Package_1_Numeric_Items : + Numeric_Items_Type(1..Number_Of_Decimal_Items) := + (new COBOL.Numeric'("0"), + new COBOL.Numeric'("591"), + new COBOL.Numeric'("6342"), + new COBOL.Numeric'("+0"), + new COBOL.Numeric'("-1539"), + new COBOL.Numeric'("+9199"), + new COBOL.Numeric'("0-"), + new COBOL.Numeric'("8934+"), + new COBOL.Numeric'("9949-")); + + Package_2_Numeric_Items : + Numeric_Items_Type(1..Number_Of_Decimal_Items) := + (new COBOL.Numeric'("3"), + new COBOL.Numeric'("105"), + new COBOL.Numeric'("1234567899"), + new COBOL.Numeric'("+8"), + new COBOL.Numeric'("-12345601"), + new COBOL.Numeric'("+9123459999"), + new COBOL.Numeric'("1-"), + new COBOL.Numeric'("123456781+"), + new COBOL.Numeric'("9499999999-")); + + + Decimal_Type_1_Items : array (1..Number_Of_Decimal_Items) + of Decimal_Type_1 := + (0.0, 5.91, 63.42, 0.0, -15.39, 91.99, 0.0, 89.34, -99.49); + + Decimal_Type_2_Items : array (1..Number_Of_Decimal_Items) + of Decimal_Type_2 := + ( 3.0, 105.0, 1234567899.0, + 8.0, -12345601.0, 9123459999.0, + -1.0, 123456781.0, -9499999999.0); + + begin + + -- Check that function Length with Display_Format parameter will + -- return the minimal length of a Numeric value (number of + -- COBOL_Characters) that will be required to hold the largest + -- value of type Num. + + if Package_1.Length(COBOL.Unsigned) /= 4 or + Package_2.Length(COBOL.Unsigned) /= 10 + then + Report.Failed("Incorrect results from function Length when " & + "used with Display_Format parameter Unsigned"); + end if; + + if Package_1.Length(Format => COBOL.Leading_Separate) /= 5 or + Package_2.Length(Format => COBOL.Leading_Separate) /= 11 + then + Report.Failed("Incorrect results from function Length when " & + "used with Display_Format parameter " & + "Leading_Separate"); + end if; + + if Package_1.Length(COBOL.Trailing_Separate) /= 5 or + Package_2.Length(COBOL.Trailing_Separate) /= 11 + then + Report.Failed("Incorrect results from function Length when " & + "used with Display_Format parameter " & + "Trailing_Separate"); + end if; + + + -- Check that function To_Decimal with Numeric and Display_Format + -- parameters will produce a decimal type Num result that corresponds + -- to parameter Item as represented by parameter Format. + + for i in 1..Number_Of_Decimal_Items loop + case i is + when 1..3 => -- Unsigned Display_Format parameter. + + if Package_1.To_Decimal(Package_1_Numeric_Items(i).all, + Format => COBOL.Unsigned) /= + Decimal_Type_1_Items(i) + then + Report.Failed + ("Incorrect result from function To_Decimal " & + "from an instantiation of Decimal_Conversions " & + "using a four-digit Decimal type, with Format " & + "parameter Unsigned, subtest index: " & + Integer'Image(i)); + end if; + + if Package_2.To_Decimal(Package_2_Numeric_Items(i).all, + Format => COBOL.Unsigned) /= + Decimal_Type_2_Items(i) + then + Report.Failed + ("Incorrect result from function To_Decimal " & + "from an instantiation of Decimal_Conversions " & + "using a ten-digit Decimal type, with Format " & + "parameter Unsigned, subtest index: " & + Integer'Image(i)); + end if; + + when 4..6 => -- Leading_Separate Display_Format parameter. + + if Package_1.To_Decimal(Package_1_Numeric_Items(i).all, + Format => COBOL.Leading_Separate) /= + Decimal_Type_1_Items(i) + then + Report.Failed + ("Incorrect result from function To_Decimal " & + "from an instantiation of Decimal_Conversions " & + "using a four-digit Decimal type, with Format " & + "parameter Leading_Separate, subtest index: " & + Integer'Image(i)); + end if; + + if Package_2.To_Decimal(Package_2_Numeric_Items(i).all, + Format => COBOL.Leading_Separate) /= + Decimal_Type_2_Items(i) + then + Report.Failed + ("Incorrect result from function To_Decimal " & + "from an instantiation of Decimal_Conversions " & + "using a ten-digit Decimal type, with Format " & + "parameter Leading_Separate, subtest index: " & + Integer'Image(i)); + end if; + + when 7..9 => -- Trailing_Separate Display_Format parameter. + + if Package_1.To_Decimal(Package_1_Numeric_Items(i).all, + COBOL.Trailing_Separate) /= + Decimal_Type_1_Items(i) + then + Report.Failed + ("Incorrect result from function To_Decimal " & + "from an instantiation of Decimal_Conversions " & + "using a four-digit Decimal type, with Format " & + "parameter Trailing_Separate, subtest index: " & + Integer'Image(i)); + end if; + + if Package_2.To_Decimal(Package_2_Numeric_Items(i).all, + COBOL.Trailing_Separate) /= + Decimal_Type_2_Items(i) + then + Report.Failed + ("Incorrect result from function To_Decimal " & + "from an instantiation of Decimal_Conversions " & + "using a ten-digit Decimal type, with Format " & + "parameter Trailing_Separate, subtest index: " & + Integer'Image(i)); + end if; + + end case; + end loop; + + + -- Check that function To_Decimal propagates Conversion_Error when + -- the value represented by Numeric type parameter Item is outside + -- the range of the Decimal_Type Num used to instantiate the package + -- Decimal_Conversions. + + declare + TC_Numeric_1 : Decimal_Type_1 := Decimal_Type_1_Items(1); + begin + -- The COBOL.Numeric type used as parameter Item represents a + -- Decimal value that is outside the range of the Decimal type + -- used to instantiate Package_1. + TC_Numeric_1 := + Package_1.To_Decimal(Item => Package_2_Numeric_Items(8).all, + Format => COBOL.Trailing_Separate); + Report.Failed("Conversion_Error not raised by To_Decimal " & + "when the value represented by parameter " & + "Item is outside the range of the Decimal_Type " & + "used to instantiate the package " & + "Decimal_Conversions"); + if TC_Numeric_1 = Decimal_Type_1_Items(1) then + Report.Comment("To Guard Against Dead Assignment Elimination " & + "-- Should never be printed"); + end if; + exception + when COBOL.Conversion_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by To_Decimal " & + "when the value represented by parameter " & + "Item is outside the range of the Decimal_Type " & + "used to instantiate the package " & + "Decimal_Conversions"); + end; + + + -- Check that function To_Display with decimal type Num and + -- Display_Format parameters returns a Numeric type result that + -- represents Item under the specific Display_Format. + + -- Unsigned Display_Format parameter. + TC_Num_1 := 13.04; + Correct_Result := (Package_1.To_Display(TC_Num_1, COBOL.Unsigned) = + "1304") AND + (Package_1.To_Display(TC_Num_1, COBOL.Unsigned) /= + "13.04"); + if not Correct_Result then + Report.Failed("Incorrect result from function To_Display with " & + "Unsigned Display_Format parameter - 1"); + end if; + + TC_Num_2 := 1234567890.0; + Correct_Result := Package_2.To_Display(TC_Num_2, + COBOL.Unsigned) = "1234567890"; + if not Correct_Result then + Report.Failed("Incorrect result from function To_Display with " & + "Unsigned Display_Format parameter - 2"); + end if; + + -- Leading_Separate Display_Format parameter. + TC_Num_1 := -34.29; + Correct_Result := (Package_1.To_Display(TC_Num_1, + COBOL.Leading_Separate) = + "-3429") AND + (Package_1.To_Display(TC_Num_1, + COBOL.Leading_Separate) /= + "-34.29"); + if not Correct_Result then + Report.Failed("Incorrect result from function To_Display with " & + "Leading_Separate Display_Format parameter - 1"); + end if; + + TC_Num_1 := 19.01; + Correct_Result := Package_1.To_Display(TC_Num_1, + COBOL.Leading_Separate) = + "+1901"; + if not Correct_Result then + Report.Failed("Incorrect result from function To_Display with " & + "Leading_Separate Display_Format parameter - 2"); + end if; + + TC_Num_2 := 1234567890.0; + Correct_Result := Package_2.To_Display(TC_Num_2, + COBOL.Leading_Separate) = + "+1234567890"; + if not Correct_Result then + Report.Failed("Incorrect result from function To_Display with " & + "Leading_Separate Display_Format parameter - 3"); + end if; + + TC_Num_2 := -1234567890.0; + Correct_Result := Package_2.To_Display(TC_Num_2, + COBOL.Leading_Separate) = + "-1234567890"; + if not Correct_Result then + Report.Failed("Incorrect result from function To_Display with " & + "Leading_Separate Display_Format parameter - 4"); + end if; + + -- Trailing_Separate Display_Format parameter. + TC_Num_1 := -99.91; + Correct_Result := (Package_1.To_Display(TC_Num_1, + COBOL.Trailing_Separate) = + "9991-") AND + (Package_1.To_Display(TC_Num_1, + COBOL.Trailing_Separate) /= + "99.91-"); + if not Correct_Result then + Report.Failed("Incorrect result from function To_Display with " & + "Trailing_Separate Display_Format parameter - 1"); + end if; + + TC_Num_1 := 51.99; + Correct_Result := Package_1.To_Display(TC_Num_1, + COBOL.Trailing_Separate) = + "5199+"; + if not Correct_Result then + Report.Failed("Incorrect result from function To_Display with " & + "Trailing_Separate Display_Format parameter - 2"); + end if; + + TC_Num_2 := 1234567890.0; + Correct_Result := Package_2.To_Display(TC_Num_2, + COBOL.Trailing_Separate) = + "1234567890+"; + if not Correct_Result then + Report.Failed("Incorrect result from function To_Display with " & + "Trailing_Separate Display_Format parameter - 3"); + end if; + + TC_Num_2 := -1234567890.0; + Correct_Result := Package_2.To_Display(TC_Num_2, + COBOL.Trailing_Separate) = + "1234567890-"; + if not Correct_Result then + Report.Failed("Incorrect result from function To_Display with " & + "Trailing_Separate Display_Format parameter - 4"); + end if; + + + -- Check that function To_Display propagates Conversion_Error when + -- parameter Item is negative and the specified Display_Format + -- parameter is Unsigned. + + begin + if Package_2.To_Display(Item => Decimal_Type_2_Items(9), + Format => COBOL.Unsigned) = + Package_2_Numeric_Items(2).all + then + Report.Comment("To Guard Against Dead Assignment Elimination " & + "-- Should never be printed"); + end if; + Report.Failed("Conversion_Error not raised by To_Display " & + "when the value represented by parameter " & + "Item is negative and the Display_Format " & + "parameter is Unsigned"); + exception + when COBOL.Conversion_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by To_Display " & + "when the value represented by parameter " & + "Item is negative and the Display_Format " & + "parameter is Unsigned"); + end; + + + exception + when The_Error : others => + Report.Failed ("The following exception was raised in the " & + "Test_Block: " & Exception_Name(The_Error)); + end Test_Block; + + Report.Result; + +end CXB4004; diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb4005.a b/gcc/testsuite/ada/acats/tests/cxb/cxb4005.a new file mode 100644 index 000000000..01f1ded1d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb4005.a @@ -0,0 +1,332 @@ +-- CXB4005.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 the function To_COBOL will convert a String +-- parameter value into a type Alphanumeric array of +-- COBOL_Characters, with lower bound of one, and length +-- equal to length of the String parameter, based on the +-- mapping Ada_to_COBOL. +-- +-- Check that the function To_Ada will convert a type +-- Alphanumeric parameter value into a String type result, +-- with lower bound of one, and length equal to the length +-- of the Alphanumeric parameter, based on the mapping +-- COBOL_to_Ada. +-- +-- Check that the Ada_to_COBOL and COBOL_to_Ada mapping +-- arrays provide a mapping capability between Ada's type +-- Character and COBOL run-time character sets. +-- +-- TEST DESCRIPTION: +-- This test checks that the functions To_COBOL and To_Ada produce +-- the correct results, based on a variety of parameter input values. +-- +-- In the first series of subtests, the results of the function +-- To_COBOL are compared against expected Alphanumeric type results, +-- and the length and lower bound of the alphanumeric result are +-- also verified. In the second series of subtests, the results of +-- the function To_Ada are compared against expected String type +-- results, and the length of the String result is also verified +-- against the Alphanumeric type parameter. +-- +-- This test also verifies that two mapping array variables defined +-- in package Interfaces.COBOL, Ada_To_COBOL and COBOL_To_Ada, are +-- available, and that they can be modified by a user at runtime. +-- Finally, the effects of user modifications on these mapping +-- variables is checked in the test. +-- +-- This test uses Fixed, Bounded, and Unbounded_Strings in combination +-- with the functions under validation. +-- +-- This test assumes that the following characters are all included +-- in the implementation defined type Interfaces.COBOL.COBOL_Character: +-- ' ', 'a'..'z', 'A'..'Z', '0'..'9', '*', ',', '.', and '$'. +-- +-- APPLICABILITY CRITERIA: +-- This test is applicable to all implementations that provide +-- package Interfaces.COBOL. If an implementation provides +-- package Interfaces.COBOL, this test must compile, execute, and +-- report "PASSED". +-- +-- +-- CHANGE HISTORY: +-- 11 Jan 96 SAIC Initial prerelease version for ACVC 2.1 +-- 30 May 96 SAIC Incorporated reviewer comments for ACVC 2.1. +-- 27 Oct 96 SAIC Incorporated reviewer comments. +-- +--! + +with Report; +with Ada.Exceptions; +with Ada.Strings.Bounded; +with Ada.Strings.Unbounded; +with Interfaces.COBOL; -- N/A => ERROR + +procedure CXB4005 is +begin + + Report.Test ("CXB4005", "Check that the functions To_COBOL and " & + "To_Ada produce correct results"); + + Test_Block: + declare + + package Bnd is new Ada.Strings.Bounded.Generic_Bounded_Length(5); + package Unb renames Ada.Strings.Unbounded; + + use Ada.Exceptions; + use Interfaces; + use Bnd; + use type Unb.Unbounded_String; + use type Interfaces.COBOL.Alphanumeric; + + TC_Alphanumeric_1 : Interfaces.COBOL.Alphanumeric(1..1); + TC_Alphanumeric_5 : Interfaces.COBOL.Alphanumeric(1..5); + TC_Alphanumeric_10 : Interfaces.COBOL.Alphanumeric(1..10); + TC_Alphanumeric_20 : Interfaces.COBOL.Alphanumeric(1..20); + + Bnd_String, + TC_Bnd_String : Bnd.Bounded_String := + Bnd.To_Bounded_String(" "); + Unb_String, + TC_Unb_String : Unb.Unbounded_String := + Unb.To_Unbounded_String(" "); + + The_String, + TC_String : String(1..20) := (" "); + + begin + + -- Check that the function To_COBOL will convert a String + -- parameter value into a type Alphanumeric array of + -- COBOL_Characters, with lower bound of one, and length + -- equal to length of the String parameter, based on the + -- mapping Ada_to_COBOL. + + Unb_String := Unb.To_Unbounded_String("A"); + TC_Alphanumeric_1 := COBOL.To_COBOL(Unb.To_String(Unb_String)); + + if TC_Alphanumeric_1 /= "A" or + TC_Alphanumeric_1'Length /= Unb.Length(Unb_String) or + TC_Alphanumeric_1'Length /= 1 or + COBOL.To_COBOL(Unb.To_String(Unb_String))'First /= 1 + then + Report.Failed("Incorrect result from function To_COBOL - 1"); + end if; + + Bnd_String := Bnd.To_Bounded_String("abcde"); + TC_Alphanumeric_5 := COBOL.To_COBOL(Bnd.To_String(Bnd_String)); + + if TC_Alphanumeric_5 /= "abcde" or + TC_Alphanumeric_5'Length /= Bnd.Length(Bnd_String) or + TC_Alphanumeric_5'Length /= 5 or + COBOL.To_COBOL(Bnd.To_String(Bnd_String))'First /= 1 + then + Report.Failed("Incorrect result from function To_COBOL - 2"); + end if; + + Unb_String := Unb.To_Unbounded_String("1A2B3c4d5F"); + TC_Alphanumeric_10 := COBOL.To_COBOL(Unb.To_String(Unb_String)); + + if TC_Alphanumeric_10 /= "1A2B3c4d5F" or + TC_Alphanumeric_10'Length /= Unb.Length(Unb_String) or + TC_Alphanumeric_10'Length /= 10 or + COBOL.To_COBOL(Unb.To_String(Unb_String))'First /= 1 + then + Report.Failed("Incorrect result from function To_COBOL - 3"); + end if; + + The_String := "abcd ghij" & "1234 7890"; + TC_Alphanumeric_20 := COBOL.To_COBOL(The_String); + + if TC_Alphanumeric_20 /= "abcd ghij1234 7890" or + TC_Alphanumeric_20'Length /= The_String'Length or + TC_Alphanumeric_20'Length /= 20 or + COBOL.To_COBOL(The_String)'First /= 1 + then + Report.Failed("Incorrect result from function To_COBOL - 4"); + end if; + + + + -- Check that the function To_Ada will convert a type + -- Alphanumeric parameter value into a String type result, + -- with lower bound of one, and length equal to the length + -- of the Alphanumeric parameter, based on the mapping + -- COBOL_to_Ada. + + TC_Unb_String := Unb.To_Unbounded_String + (COBOL.To_Ada(TC_Alphanumeric_1)); + + if TC_Unb_String /= "A" or + TC_Alphanumeric_1'Length /= Unb.Length(TC_Unb_String) or + Unb.Length(TC_Unb_String) /= 1 or + COBOL.To_Ada(TC_Alphanumeric_1)'First /= 1 + then + Report.Failed("Incorrect value returned from function To_Ada - 1"); + end if; + + TC_Bnd_String := Bnd.To_Bounded_String + (COBOL.To_Ada(TC_Alphanumeric_5)); + + if TC_Bnd_String /= "abcde" or + TC_Alphanumeric_5'Length /= Bnd.Length(TC_Bnd_String) or + Bnd.Length(TC_Bnd_String) /= 5 or + COBOL.To_Ada(TC_Alphanumeric_5)'First /= 1 + then + Report.Failed("Incorrect value returned from function To_Ada - 2"); + end if; + + TC_Unb_String := Unb.To_Unbounded_String + (COBOL.To_Ada(TC_Alphanumeric_10)); + + if TC_Unb_String /= "1A2B3c4d5F" or + TC_Alphanumeric_10'Length /= Unb.Length(TC_Unb_String) or + Unb.Length(TC_Unb_String) /= 10 or + COBOL.To_Ada(TC_Alphanumeric_10)'First /= 1 + then + Report.Failed("Incorrect value returned from function To_Ada - 3"); + end if; + + TC_String := COBOL.To_Ada(TC_Alphanumeric_20); + + if TC_String /= "abcd ghij1234 7890" or + TC_Alphanumeric_20'Length /= TC_String'Length or + TC_String'Length /= 20 or + COBOL.To_Ada(TC_Alphanumeric_20)'First /= 1 + then + Report.Failed("Incorrect value returned from function To_Ada - 4"); + end if; + + + -- Check the two functions when used in combination. + + if COBOL.To_COBOL(Item => COBOL.To_Ada("This is a test")) /= + "This is a test" or + COBOL.To_COBOL(COBOL.To_Ada("1234567890abcdeFGHIJ")) /= + "1234567890abcdeFGHIJ" + then + Report.Failed("Incorrect result returned when using the " & + "functions To_Ada and To_COBOL in combination"); + end if; + + + + -- Check that the Ada_to_COBOL and COBOL_to_Ada mapping + -- arrays provide a mapping capability between Ada's type + -- Character and COBOL run-time character sets. + + Interfaces.COBOL.Ada_To_COBOL('a') := 'A'; + Interfaces.COBOL.Ada_To_COBOL('b') := 'B'; + Interfaces.COBOL.Ada_To_COBOL('c') := 'C'; + Interfaces.COBOL.Ada_To_COBOL('d') := '1'; + Interfaces.COBOL.Ada_To_COBOL('e') := '2'; + Interfaces.COBOL.Ada_To_COBOL('f') := '3'; + Interfaces.COBOL.Ada_To_COBOL(' ') := '*'; + + Unb_String := Unb.To_Unbounded_String("b"); + TC_Alphanumeric_1 := COBOL.To_COBOL(Unb.To_String(Unb_String)); + + if TC_Alphanumeric_1 /= "B" then + Report.Failed("Incorrect result from function To_COBOL after " & + "modification to Ada_To_COBOL mapping array - 1"); + end if; + + Bnd_String := Bnd.To_Bounded_String("abcde"); + TC_Alphanumeric_5 := COBOL.To_COBOL(Bnd.To_String(Bnd_String)); + + if TC_Alphanumeric_5 /= "ABC12" then + Report.Failed("Incorrect result from function To_COBOL after " & + "modification to Ada_To_COBOL mapping array - 2"); + end if; + + Unb_String := Unb.To_Unbounded_String("1a2B3c4d5e"); + TC_Alphanumeric_10 := COBOL.To_COBOL(Unb.To_String(Unb_String)); + + if TC_Alphanumeric_10 /= "1A2B3C4152" then + Report.Failed("Incorrect result from function To_COBOL after " & + "modification to Ada_To_COBOL mapping array - 3"); + end if; + + The_String := "abcd ghij" & "1234 7890"; + TC_Alphanumeric_20 := COBOL.To_COBOL(The_String); + + if TC_Alphanumeric_20 /= "ABC1**ghij1234**7890" then + Report.Failed("Incorrect result from function To_COBOL after " & + "modification to Ada_To_COBOL mapping array - 4"); + end if; + + + -- Reset the Ada_To_COBOL mapping array to its original state. + + Interfaces.COBOL.Ada_To_COBOL('a') := 'a'; + Interfaces.COBOL.Ada_To_COBOL('b') := 'b'; + Interfaces.COBOL.Ada_To_COBOL('c') := 'c'; + Interfaces.COBOL.Ada_To_COBOL('d') := 'd'; + Interfaces.COBOL.Ada_To_COBOL('e') := 'e'; + Interfaces.COBOL.Ada_To_COBOL('f') := 'f'; + Interfaces.COBOL.Ada_To_COBOL(' ') := ' '; + + -- Modify the COBOL_To_Ada mapping array to check its effect on + -- the function To_Ada. + + Interfaces.COBOL.COBOL_To_Ada(' ') := '*'; + Interfaces.COBOL.COBOL_To_Ada('$') := 'F'; + Interfaces.COBOL.COBOL_To_Ada('1') := '7'; + Interfaces.COBOL.COBOL_To_Ada('.') := ','; + + Unb_String := Unb.To_Unbounded_String(" $$100.00"); + TC_Alphanumeric_10 := COBOL.To_COBOL(Unb.To_String(Unb_String)); + TC_Unb_String := Unb.To_Unbounded_String( + COBOL.To_Ada(TC_Alphanumeric_10)); + + if Unb.To_String(TC_Unb_String) /= "**FF700,00" then + Report.Failed("Incorrect result from function To_Ada after " & + "modification of COBOL_To_Ada mapping array - 1"); + end if; + + Interfaces.COBOL.COBOL_To_Ada('*') := ' '; + Interfaces.COBOL.COBOL_To_Ada('F') := '$'; + Interfaces.COBOL.COBOL_To_Ada('7') := '1'; + Interfaces.COBOL.COBOL_To_Ada(',') := '.'; + + if COBOL.To_Ada(COBOL.To_COBOL(Unb.To_String(TC_Unb_String))) /= + Unb_String + then + Report.Failed("Incorrect result from function To_Ada after " & + "modification of COBOL_To_Ada mapping array - 2"); + end if; + + + exception + when The_Error : others => + Report.Failed ("The following exception was raised in the " & + "Test_Block: " & Exception_Name(The_Error)); + end Test_Block; + + Report.Result; + +end CXB4005; diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb4006.a b/gcc/testsuite/ada/acats/tests/cxb/cxb4006.a new file mode 100644 index 000000000..6e491eebf --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb4006.a @@ -0,0 +1,322 @@ +-- CXB4006.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 the function Valid with Packed_Decimal and Packed_Format +-- parameters returns True if Item (the Packed_Decimal parameter) has +-- a value consistent with the Packed_Format parameter. +-- +-- Check that the function Length with Packed_Format parameter returns +-- the minimal length of a Packed_Decimal value sufficient to hold any +-- value of type Num when represented according to parameter Format. +-- +-- Check that the function To_Decimal with Packed_Decimal and +-- Packed_Format parameters produces a decimal type value corresponding +-- to the Packed_Decimal parameter value Item, under the conditions of +-- the Packed_Format parameter Format. +-- +-- Check that the function To_Packed with Decimal (Num) and +-- Packed_Format parameters produces a Packed_Decimal result that +-- corresponds to the decimal parameter under conditions of the +-- Packed_Format parameter. +-- +-- Check that Conversion_Error is propagated by function To_Packed if +-- the value of the decimal parameter Item is negative and the specified +-- Packed_Format parameter is Packed_Unsigned. +-- +-- +-- TEST DESCRIPTION: +-- This test checks the results from instantiated versions of +-- several functions that deal with parameters or results of type +-- Packed_Decimal. Since the rules for the formation of Packed_Decimal +-- values are implementation defined, several of the subtests cannot +-- directly check the accuracy of the results produced. Instead, they +-- verify that the result is within a range of possible values, or +-- that the result of one function can be converted back to the original +-- actual parameter using a "mirror image" conversion function. +-- +-- APPLICABILITY CRITERIA: +-- This test is applicable to all implementations that provide +-- package Interfaces.COBOL. If an implementation provides +-- package Interfaces.COBOL, this test must compile, execute, and +-- report "PASSED". +-- +-- +-- CHANGE HISTORY: +-- 12 Feb 96 SAIC Initial release for 2.1. +-- 30 May 96 SAIC Incorporated reviewer comments for ACVC 2.1. +-- 27 Oct 96 SAIC Incorporated reviewer comments. +-- +--! + +with Report; +with Ada.Exceptions; +with Interfaces.COBOL; -- N/A => ERROR + +procedure CXB4006 is +begin + + Report.Test ("CXB4006", "Check that the functions Valid, Length, " & + "To_Decimal, and To_Packed specific to " & + "Packed_Decimal parameters produce correct " & + "results"); + + Test_Block: + declare + + use Interfaces.COBOL; + use Ada.Exceptions; + use type Interfaces.COBOL.Numeric; + + type Decimal_Type_1 is delta 0.1 digits 6; + type Decimal_Type_2 is delta 0.01 digits 8; + type Decimal_Type_3 is delta 0.001 digits 10; + type Decimal_Type_4 is delta 0.0001 digits 12; + + package Pack_1 is new Decimal_Conversions(Decimal_Type_1); + package Pack_2 is new Decimal_Conversions(Decimal_Type_2); + package Pack_3 is new Decimal_Conversions(Decimal_Type_3); + package Pack_4 is new Decimal_Conversions(Decimal_Type_4); + + TC_Dec_1 : Decimal_Type_1 := 12345.6; + TC_Dec_2 : Decimal_Type_2 := 123456.78; + TC_Dec_3 : Decimal_Type_3 := 1234567.890; + TC_Dec_4 : Decimal_Type_4 := 12345678.9012; + TC_Min_Length : Natural := 1; + TC_Max_Length : Natural := 16; + + begin + + -- Check that the function Valid with Packed_Decimal and Packed_Format + -- parameters returns True if Item (the Packed_Decimal parameter) has + -- a value consistent with the Packed_Format parameter. + -- Note: Since the formation rules for Packed_Decimal values are + -- implementation defined, the parameter values here are + -- created by function To_Packed. + + TC_Dec_1 := 1434.3; + if not Pack_1.Valid(Item => Pack_1.To_Packed(TC_Dec_1, + Packed_Unsigned), + Format => Packed_Unsigned) + then + Report.Failed("Incorrect result from function Valid - 1"); + end if; + + TC_Dec_2 := -4321.03; + if not Pack_2.Valid(Pack_2.To_Packed(TC_Dec_2, Packed_Signed), + Format => Packed_Signed) or + Pack_2.Valid(Pack_2.To_Packed(TC_Dec_2, Packed_Signed), + Format => Packed_Unsigned) + then + Report.Failed("Incorrect result from function Valid - 2"); + end if; + + TC_Dec_3 := 1234567.890; + if not Pack_3.Valid(Pack_3.To_Packed(TC_Dec_3, Packed_Unsigned), + Packed_Unsigned) + then + Report.Failed("Incorrect result from function Valid - 3"); + end if; + + TC_Dec_4 := -234.6789; + if not Pack_4.Valid(Item => Pack_4.To_Packed(TC_Dec_4, + Packed_Signed), + Format => Packed_Signed) or + Pack_4.Valid(Item => Pack_4.To_Packed(TC_Dec_4, Packed_Signed), + Format => Packed_Unsigned) + then + Report.Failed("Incorrect result from function Valid - 4"); + end if; + + + + -- Check that the function Length with Packed_Format parameter returns + -- the minimal length of a Packed_Decimal value sufficient to hold any + -- value of type Num when represented according to parameter Format. + + if NOT (Pack_1.Length(Packed_Signed) >= TC_Min_Length AND + Pack_1.Length(Packed_Signed) <= TC_Max_Length AND + Pack_1.Length(Packed_Unsigned) >= TC_Min_Length AND + Pack_1.Length(Packed_Unsigned) <= TC_Max_Length) + then + Report.Failed("Incorrect result from function Length - 1"); + end if; + + if NOT (Pack_2.Length(Packed_Signed) >= TC_Min_Length AND + Pack_2.Length(Packed_Signed) <= TC_Max_Length AND + Pack_2.Length(Packed_Unsigned) >= TC_Min_Length AND + Pack_2.Length(Packed_Unsigned) <= TC_Max_Length) + then + Report.Failed("Incorrect result from function Length - 2"); + end if; + + if NOT (Pack_3.Length(Packed_Signed) >= TC_Min_Length AND + Pack_3.Length(Packed_Signed) <= TC_Max_Length AND + Pack_3.Length(Packed_Unsigned) >= TC_Min_Length AND + Pack_3.Length(Packed_Unsigned) <= TC_Max_Length) + then + Report.Failed("Incorrect result from function Length - 3"); + end if; + + if NOT (Pack_4.Length(Packed_Signed) >= TC_Min_Length AND + Pack_4.Length(Packed_Signed) <= TC_Max_Length AND + Pack_4.Length(Packed_Unsigned) >= TC_Min_Length AND + Pack_4.Length(Packed_Unsigned) <= TC_Max_Length) + then + Report.Failed("Incorrect result from function Length - 4"); + end if; + + + + -- Check that the function To_Decimal with Packed_Decimal and + -- Packed_Format parameters produces a decimal type value corresponding + -- to the Packed_Decimal parameter value Item, under the conditions of + -- the Packed_Format parameter Format. + + begin + TC_Dec_1 := 1234.5; + if Pack_1.To_Decimal(Item => Pack_1.To_Packed(TC_Dec_1, + Packed_Unsigned), + Format => Packed_Unsigned) /= TC_Dec_1 + then + Report.Failed("Incorrect result from function To_Decimal - 1"); + end if; + exception + when The_Error : others => + Report.Failed("The following exception was raised in " & + "subtest 1 of function To_Decimal: " & + Exception_Name(The_Error)); + end; + + begin + TC_Dec_2 := -123456.50; + if Pack_2.To_Decimal(Pack_2.To_Packed(TC_Dec_2, Packed_Signed), + Format => Packed_Signed) /= TC_Dec_2 + then + Report.Failed("Incorrect result from function To_Decimal - 2"); + end if; + exception + when The_Error : others => + Report.Failed("The following exception was raised in " & + "subtest 2 of function To_Decimal: " & + Exception_Name(The_Error)); + end; + + begin + TC_Dec_3 := 1234567.809; + if Pack_3.To_Decimal(Pack_3.To_Packed(TC_Dec_3, Packed_Unsigned), + Packed_Unsigned) /= TC_Dec_3 + then + Report.Failed("Incorrect result from function To_Decimal - 3"); + end if; + exception + when The_Error : others => + Report.Failed("The following exception was raised in " & + "subtest 3 of function To_Decimal: " & + Exception_Name(The_Error)); + end; + + begin + TC_Dec_4 := -789.1234; + if Pack_4.To_Decimal(Item => Pack_4.To_Packed(TC_Dec_4, + Packed_Signed), + Format => Packed_Signed) /= TC_Dec_4 + then + Report.Failed("Incorrect result from function To_Decimal - 4"); + end if; + exception + when The_Error : others => + Report.Failed("The following exception was raised in " & + "subtest 4 of function To_Decimal: " & + Exception_Name(The_Error)); + end; + + + + -- Check that the function To_Packed with Decimal (Num) and + -- Packed_Format parameters produces a Packed_Decimal result that + -- corresponds to the decimal parameter under conditions of the + -- Packed_Format parameter. + + if Pack_1.To_Packed(Item => 123.4, Format => Packed_Unsigned) = + Pack_1.To_Packed(Item => -123.4, Format => Packed_Signed) + then + Report.Failed("Incorrect result from function To_Packed - 1"); + end if; + + if Pack_2.To_Packed( 123.45, Format => Packed_Unsigned) = + Pack_2.To_Packed(-123.45, Format => Packed_Signed) + then + Report.Failed("Incorrect result from function To_Packed - 2"); + end if; + + if Pack_3.To_Packed(Item => 123.456, Format => Packed_Unsigned) = + Pack_3.To_Packed(Item => -123.456, Format => Packed_Signed) + then + Report.Failed("Incorrect result from function To_Packed - 3"); + end if; + + if (Pack_4.To_Packed( 123.4567, Packed_Unsigned) = + Pack_4.To_Packed(-123.4567, Packed_Signed)) or + (Pack_4.To_Packed(12345678.9012, Packed_Unsigned) = + Pack_4.To_Packed(12345678.9013, Packed_Unsigned)) or + (Pack_4.To_Packed(12345678.9012, Packed_Unsigned) = + Pack_4.To_Packed(22345678.9012, Packed_Unsigned)) + then + Report.Failed("Incorrect result from function To_Packed - 4"); + end if; + + + -- Check that Conversion_Error is propagated by function To_Packed if + -- the value of the decimal parameter Item is negative and the + -- specified Packed_Format parameter is Packed_Unsigned. + + begin + if Pack_1.To_Packed(Item => -12.3, Format => Packed_Unsigned) = + Pack_1.To_Packed(Item => 12.3, Format => Packed_Signed) + then + Report.Comment("Should never be printed"); + end if; + Report.Failed("Conversion_Error not raised following call to " & + "function To_Packed with a negative parameter " & + "Item and Packed_Format parameter Packed_Unsigned"); + exception + when Conversion_Error => null; -- OK, expected exception. + when The_Error : others => + Report.Failed(Exception_Name(The_Error) & " was incorrectly " & + "raised following call to function To_Packed " & + "with a negative parameter Item and " & + "Packed_Format parameter Packed_Unsigned"); + end; + + exception + when The_Error : others => + Report.Failed("The following exception was raised in the " & + "Test_Block: " & Exception_Name(The_Error)); + end Test_Block; + + Report.Result; + +end CXB4006; diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb4007.a b/gcc/testsuite/ada/acats/tests/cxb/cxb4007.a new file mode 100644 index 000000000..c4e064176 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb4007.a @@ -0,0 +1,271 @@ +-- CXB4007.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 the function Valid with Byte_Array and Binary_Format +-- parameters returns True if the Byte_Array parameter corresponds +-- to any value inside the range of type Num. +-- Check that function Valid returns False if the Byte_Array parameter +-- corresponds to a value outside the range of Num. +-- +-- Check that function Length with Binary_Format parameter will return +-- the minimum length of a Byte_Array value required to hold any value +-- of decimal type Num. +-- +-- Check that function To_Decimal with Byte_Array and Binary_Format +-- parameters will return a decimal type value that corresponds to +-- parameter Item (of type Byte_Array) under the specified Format. +-- +-- Check that Conversion_Error is propagated by function To_Decimal if +-- the Byte_Array parameter Item represents a decimal value outside the +-- range of decimal type Num. +-- +-- Check that function To_Binary will produce a Byte_Array result that +-- corresponds to the decimal type parameter Item, under the specified +-- Binary_Format. +-- +-- TEST DESCRIPTION: +-- This test uses several instantiations of generic package +-- Decimal_Conversions to provide appropriate test material. +-- This test uses the function To_Binary to create all Byte_Array +-- parameter values used in calls to functions Valid and To_Decimal. +-- The function Valid is tested with parameters to provide both +-- valid and invalid expected results. This test also checks that +-- Function To_Decimal produces expected results in cases where each +-- of the three predefined Binary_Format constants are used in the +-- function calls. In addition, the prescribed propagation of +-- Conversion_Error by function To_Decimal is verified. +-- +-- APPLICABILITY CRITERIA: +-- This test is applicable to all implementations that provide +-- package Interfaces.COBOL. If an implementation provides +-- package Interfaces.COBOL, this test must compile, execute, and +-- report "PASSED". +-- +-- +-- CHANGE HISTORY: +-- 14 Feb 96 SAIC Initial release for 2.1. +-- 30 May 96 SAIC Incorporated reviewer comments for ACVC 2.1. +-- 27 Oct 96 SAIC Incorporated reviewer comments. +-- 05 JAN 98 EDS Remove incorrect subtest. +--! + +with Report; +with Ada.Exceptions; +with Interfaces.COBOL; -- N/A => ERROR + +procedure CXB4007 is +begin + + Report.Test ("CXB4007", "Check that functions Valid, Length, To_Decimal " & + "and To_Binary specific to Byte_Array and " & + "Binary_Format parameters produce correct results"); + + Test_Block: + declare + + use Interfaces.COBOL; + use Ada.Exceptions; + use type Interfaces.COBOL.Numeric; + + type Decimal_Type_1 is delta 0.1 digits 6; + type Decimal_Type_2 is delta 0.01 digits 8; + type Decimal_Type_3 is delta 0.001 digits 10; + type Decimal_Type_4 is delta 0.0001 digits 12; + + package Pack_1 is new Decimal_Conversions(Decimal_Type_1); + package Pack_2 is new Decimal_Conversions(Decimal_Type_2); + package Pack_3 is new Decimal_Conversions(Decimal_Type_3); + package Pack_4 is new Decimal_Conversions(Decimal_Type_4); + + TC_Dec_1 : Decimal_Type_1 := 12345.6; + TC_Dec_2 : Decimal_Type_2 := 123456.78; + TC_Dec_3 : Decimal_Type_3 := 1234567.890; + TC_Dec_4 : Decimal_Type_4 := 12345678.9012; + TC_Min_Length : Natural := 1; + TC_Max_Length : Natural := 16; + TC_Valid : Boolean := False; + + begin + + -- Check that the function Valid with Byte_Array and Binary_Format + -- parameters returns True if the Byte_Array parameter corresponds to + -- any value inside the range of type Num. + + if not Pack_1.Valid(Item => Pack_1.To_Binary(TC_Dec_1, + High_Order_First), + Format => High_Order_First) or + not Pack_1.Valid(Pack_1.To_Binary(0.0, Low_Order_First), + Format => Low_Order_First) + then + Report.Failed("Incorrect result from function Valid, using " & + "parameters that should return a positive result - 1"); + end if; + + TC_Valid := (Pack_2.Valid(Pack_2.To_Binary(TC_Dec_2, High_Order_First), + Format => High_Order_First) and + Pack_2.Valid(Pack_2.To_Binary(0.01, Low_Order_First), + Format => Low_Order_First)); + if not TC_Valid then + Report.Failed("Incorrect result from function Valid, using " & + "parameters that should return a positive result - 2"); + end if; + + if not Pack_3.Valid(Item => Pack_3.To_Binary(TC_Dec_3, + Low_Order_First), + Format => Low_Order_First) or + not Pack_3.Valid(Pack_3.To_Binary(0.001, High_Order_First), + Format => High_Order_First) or + not Pack_3.Valid(Pack_3.To_Binary(123.456, Native_Binary), + Native_Binary) + then + Report.Failed("Incorrect result from function Valid, using " & + "parameters that should return a positive result - 3"); + end if; + + + -- Check that function Valid returns False if the Byte_Array parameter + -- corresponds to a value outside the range of Num. + -- Note: use a Byte_Array value Item created by an instantiation of + -- To_Binary with a larger Num type as the generic formal. + + if Pack_1.Valid(Item => Pack_2.To_Binary(TC_Dec_2, Low_Order_First), + Format => Low_Order_First) or + Pack_2.Valid(Pack_3.To_Binary(TC_Dec_3, High_Order_First), + Format => High_Order_First) or + Pack_3.Valid(Pack_4.To_Binary(TC_Dec_4, Native_Binary), + Native_Binary) + then + Report.Failed("Incorrect result from function Valid, using " & + "parameters that should return a negative result"); + end if; + + + -- Check that function Length with Binary_Format parameter will return + -- the minimum length of a Byte_Array value required to hold any value + -- of decimal type Num. + + if not (Pack_1.Length(Native_Binary) >= TC_Min_Length and + Pack_1.Length(Low_Order_First) <= TC_Max_Length and + Pack_2.Length(High_Order_First) >= TC_Min_Length and + Pack_2.Length(Native_Binary) <= TC_Max_Length and + Pack_3.Length(Low_Order_First) >= TC_Min_Length and + Pack_3.Length(High_Order_First) <= TC_Max_Length and + Pack_4.Length(Native_Binary) >= TC_Min_Length and + Pack_4.Length(Low_Order_First) <= TC_Max_Length) + then + Report.Failed("Incorrect result from function Length"); + end if; + + + + -- Check that function To_Decimal with Byte_Array and Binary_Format + -- parameters will return a decimal type value that corresponds to + -- parameter Item (of type Byte_Array) under the specified Format. + + if Pack_1.To_Decimal(Item => Pack_1.To_Binary(Item => TC_Dec_1, + Format => Native_Binary), + Format => Native_Binary) /= + TC_Dec_1 + then + Report.Failed("Incorrect result from function To_Decimal - 1"); + end if; + + if Pack_3.To_Decimal(Pack_3.To_Binary(TC_Dec_3, High_Order_First), + Format => High_Order_First) /= + TC_Dec_3 + then + Report.Failed("Incorrect result from function To_Decimal - 2"); + end if; + + if Pack_4.To_Decimal(Pack_4.To_Binary(TC_Dec_4, Low_Order_First), + Low_Order_First) /= + TC_Dec_4 + then + Report.Failed("Incorrect result from function To_Decimal - 3"); + end if; + + + + -- Check that Conversion_Error is propagated by function To_Decimal + -- if the Byte_Array parameter Item represents a decimal value outside + -- the range of decimal type Num. + -- Note: use a Byte_Array value Item created by an instantiation of + -- To_Binary with a larger Num type as the generic formal. + + begin + TC_Dec_4 := 99999.9001; + TC_Dec_1 := Pack_1.To_Decimal(Pack_4.To_Binary(TC_Dec_4, + Native_Binary), + Format => Native_Binary); + if TC_Dec_1 = 99999.9 then + Report.Comment("Minimize dead assignment optimization -- " & + "Should never be printed"); + end if; + Report.Failed("Conversion_Error not raised following call to " & + "function To_Decimal if the Byte_Array parameter " & + "Item represents a decimal value outside the " & + "range of decimal type Num"); + exception + when Conversion_Error => null; -- OK, expected exception. + when The_Error : others => + Report.Failed(Exception_Name(The_Error) & " was incorrectly " & + "raised following call to function To_Decimal " & + "if the Byte_Array parameter Item represents " & + "a decimal value outside the range of decimal " & + "type Num"); + end; + + + + -- Check that function To_Binary will produce a Byte_Array result that + -- corresponds to the decimal type parameter Item, under the specified + -- Binary_Format. + + -- Different ordering. + TC_Dec_1 := 12345.6; + if Pack_1.To_Binary(TC_Dec_1, Low_Order_First) = + Pack_1.To_Binary(TC_Dec_1, High_Order_First) + then + Report.Failed("Incorrect result from function To_Binary - 1"); + end if; + + -- Variable vs. literal. + TC_Dec_2 := 12345.00; + if Pack_2.To_Binary(TC_Dec_2, Native_Binary) /= + Pack_2.To_Binary(12345.00, Native_Binary) + then + Report.Failed("Incorrect result from function To_Binary - 2"); + end if; + + exception + when The_Error : others => + Report.Failed("The following exception was raised in the " & + "Test_Block: " & Exception_Name(The_Error)); + end Test_Block; + + Report.Result; + +end CXB4007; diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb4008.a b/gcc/testsuite/ada/acats/tests/cxb/cxb4008.a new file mode 100644 index 000000000..5ab8e6b03 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb4008.a @@ -0,0 +1,248 @@ +-- CXB4008.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 the function To_Decimal with Binary parameter will return +-- the corresponding value of the decimal type Num. +-- +-- Check that the function To_Decimal with Long_Binary parameter will +-- return the corresponding value of the decimal type Num. +-- +-- Check that both of the To_Decimal functions described above will +-- propagate Conversion_Error if the converted value Item is outside +-- the range of type Num. +-- +-- Check that the function To_Binary converts a value of the Ada +-- decimal type Num into a Binary type value. +-- +-- Check that the function To_Long_Binary converts a value of the Ada +-- decimal type Num into a Long_Binary type value. +-- +-- TEST DESCRIPTION: +-- This test uses several instantiations of generic package +-- Decimal_Conversions to provide appropriate test material. +-- Two of the instantiations use decimal types as generic actuals +-- that include the implementation defined constants Max_Digits_Binary +-- and Max_Digits_Long_Binary in their definition. +-- +-- Subtests are included for both versions of function To_Decimal, +-- (Binary and Long_Binary parameters), and include checks that +-- Conversion_Error is propagated under the appropriate circumstances. +-- Functions To_Binary and To_Long_Binary are "sanity" checked, to +-- ensure that the functions are available, and that the results are +-- appropriate based on their parameter input. +-- +-- APPLICABILITY CRITERIA: +-- This test is applicable to all implementations that provide +-- package Interfaces.COBOL. If an implementation provides +-- package Interfaces.COBOL, this test must compile, execute, and +-- report "PASSED". +-- +-- +-- CHANGE HISTORY: +-- 21 Feb 96 SAIC Initial release for 2.1. +-- 10 Jun 96 SAIC Incorporated reviewer comments for ACVC 2.1. +-- 27 Oct 96 SAIC Incorporated reviewer comments. +-- +--! + +with Report; +with Ada.Exceptions; +with Interfaces.COBOL; -- N/A => ERROR + +procedure CXB4008 is +begin + + Report.Test ("CXB4008", "Check that functions To_Decimal, To_Binary, and " & + "To_Long_Binary produce the correct results"); + + Test_Block: + declare + + use Interfaces.COBOL; + use Ada.Exceptions; + use type Interfaces.COBOL.Numeric; + + type Decimal_Type_1 is delta 0.1 digits 6; + type Decimal_Type_2 is delta 0.01 digits Max_Digits_Binary; + type Decimal_Type_3 is delta 0.001 digits 10; + type Decimal_Type_4 is delta 0.0001 digits Max_Digits_Long_Binary; + + package Pack_1 is new Decimal_Conversions(Decimal_Type_1); + package Pack_2 is new Decimal_Conversions(Decimal_Type_2); + package Pack_3 is new Decimal_Conversions(Decimal_Type_3); + package Pack_4 is new Decimal_Conversions(Decimal_Type_4); + + TC_Dec_1 : Decimal_Type_1 := 12345.0; + TC_Dec_2 : Decimal_Type_2 := 123456.00; + TC_Dec_3 : Decimal_Type_3 := 1234567.000; + TC_Dec_4 : Decimal_Type_4 := 12345678.0000; + TC_Binary : Interfaces.COBOL.Binary; + TC_Long_Binary : Interfaces.COBOL.Long_Binary; + + begin + + -- Check that the function To_Decimal with Binary parameter will + -- return the corresponding value of the decimal type Num. + + if Pack_1.To_Decimal(Item => Pack_1.To_Binary(TC_Dec_1)) /= TC_Dec_1 or + Pack_2.To_Decimal(Pack_2.To_Binary(TC_Dec_2)) /= TC_Dec_2 + then + Report.Failed("Incorrect result from function To_Decimal with " & + "Binary parameter - 1"); + end if; + + if Pack_1.To_Decimal(Item => Pack_1.To_Binary(1234.0)) /= 1234.0 then + Report.Failed("Incorrect result from function To_Decimal with " & + "Binary parameter - 2"); + end if; + + TC_Binary := Pack_2.To_Binary(TC_Dec_2); + if Pack_2.To_Decimal(TC_Binary) /= TC_Dec_2 then + Report.Failed("Incorrect result from function To_Decimal with " & + "Binary parameter - 3"); + end if; + + + + -- Check that the function To_Decimal with Long_Binary parameter + -- will return the corresponding value of the decimal type Num. + + if Pack_3.To_Decimal(Item => Pack_3.To_Long_Binary(TC_Dec_3)) /= + TC_Dec_3 or + Pack_4.To_Decimal(Pack_4.To_Long_Binary(TC_Dec_4)) /= + TC_Dec_4 + then + Report.Failed("Incorrect result from function To_Decimal with " & + "Long_Binary parameter - 1"); + end if; + + if Pack_3.To_Decimal(Pack_3.To_Long_Binary(1234567.0)) /= 1234567.0 then + Report.Failed("Incorrect result from function To_Decimal with " & + "Long_Binary parameter - 2"); + end if; + + TC_Long_Binary := Pack_4.To_Long_Binary(TC_Dec_4); + if Pack_4.To_Decimal(TC_Long_Binary) /= TC_Dec_4 then + Report.Failed("Incorrect result from function To_Decimal with " & + "Long_Binary parameter - 3"); + end if; + + + + -- Check that both of the To_Decimal functions described above + -- will propagate Conversion_Error if the converted value Item is + -- outside the range of type Num. + -- Note: Binary/Long_Binary parameter values are created by an + -- instantiation of To_Binary/To_Long_Binary with a larger + -- Num type as the generic formal. + + Binary_Parameter: + begin + TC_Dec_1 := Pack_1.To_Decimal(Pack_2.To_Binary(123456.78)); + Report.Failed("Conversion_Error was not raised by function " & + "To_Decimal with Binary parameter, when the " & + "converted value Item was outside the range " & + "of type Num"); + if TC_Dec_1 = 12345.6 then -- Avoid dead assignment optimization. + Report.Comment("Should never be printed"); + end if; + exception + when Conversion_Error => null; -- OK, expected exception. + when The_Error : others => + Report.Failed(Ada.Exceptions.Exception_Name(The_Error) & " " & + "was incorrectly raised by function To_Decimal " & + "with Binary parameter, when the converted " & + "value Item was outside the range of type Num"); + end Binary_Parameter; + + Long_Binary_Parameter: + begin + TC_Dec_3 := Pack_3.To_Decimal(Pack_4.To_Long_Binary(TC_Dec_4)); + Report.Failed("Conversion_Error was not raised by function " & + "To_Decimal with Long_Binary parameter, when " & + "the converted value Item was outside the range " & + "of type Num"); + if TC_Dec_3 = 123456.78 then -- Avoid dead assignment optimization. + Report.Comment("Should never be printed"); + end if; + exception + when Conversion_Error => null; -- OK, expected exception. + when The_Error : others => + Report.Failed(Ada.Exceptions.Exception_Name(The_Error) & " " & + "was incorrectly raised by function To_Decimal " & + "with Long_Binary parameter, when the converted " & + "value Item was outside the range of type Num"); + end Long_Binary_Parameter; + + + + -- Check that the function To_Binary converts a value of the Ada + -- decimal type Num into a Binary type value. + + TC_Dec_1 := 123.4; + TC_Dec_2 := 9.99; + if Pack_1.To_Binary(TC_Dec_1) = Pack_1.To_Binary(-TC_Dec_1) or + Pack_2.To_Binary(TC_Dec_2) = Pack_2.To_Binary(-TC_Dec_2) + then + Report.Failed("Incorrect result from function To_Binary - 1"); + end if; + + if Pack_1.To_Binary(1.1) = Pack_1.To_Binary(-1.1) or + Pack_2.To_Binary(9999.99) = Pack_2.To_Binary(-9999.99) + then + Report.Failed("Incorrect result from function To_Binary - 2"); + end if; + + + -- Check that the function To_Long_Binary converts a value of the + -- Ada decimal type Num into a Long_Binary type value. + + TC_Dec_3 := 9.001; + TC_Dec_4 := 123.4567; + if Pack_3.To_Long_Binary(TC_Dec_3) = Pack_3.To_Long_Binary(-TC_Dec_3) or + Pack_4.To_Long_Binary(TC_Dec_4) = Pack_4.To_Long_Binary(-TC_Dec_4) + then + Report.Failed("Incorrect result from function To_Long_Binary - 1"); + end if; + + if Pack_3.To_Long_Binary(1.011) = + Pack_3.To_Long_Binary(-1.011) or + Pack_4.To_Long_Binary(2345678.9012) = + Pack_4.To_Long_Binary(-2345678.9012) + then + Report.Failed("Incorrect result from function To_Long_Binary - 2"); + end if; + + + exception + when The_Error : others => + Report.Failed("The following exception was raised in the " & + "Test_Block: " & Exception_Name(The_Error)); + end Test_Block; + + Report.Result; + +end CXB4008; diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb5001.a b/gcc/testsuite/ada/acats/tests/cxb/cxb5001.a new file mode 100644 index 000000000..a681c5f13 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb5001.a @@ -0,0 +1,110 @@ +-- CXB5001.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 the specification of the package Interfaces.Fortran +-- are available for use. +-- +-- TEST DESCRIPTION: +-- This test verifies that the types and subprograms specified for the +-- interface are present +-- +-- APPLICABILITY CRITERIA: +-- If an implementation provides package Interfaces.Fortran, this test +-- must compile, execute, and report "PASSED". +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 28 Feb 96 SAIC Added applicability criteria. +-- 27 Oct 96 SAIC Incorporated reviewer comments. +-- +--! + +with Report; +with Interfaces.Fortran; -- N/A => ERROR + +procedure CXB5001 is + package Fortran renames Interfaces.FORTRAN; + +begin + + Report.Test ("CXB5001", "Check the specification of Interfaces.Fortran"); + + + declare -- encapsulate the test + + + TC_Int : integer := 1; + TC_Natural : natural; + TC_String : String := "ABCD"; + TC_Character : Character := 'a'; + + TST_Fortran_Integer : FORTRAN.Fortran_Integer; + + TST_Real : Fortran.Real; + TST_Double_Precision : Fortran.Double_Precision; + + TST_Logical : Fortran.Logical := FORTRAN.true; + -- verify it is a Boolean + TST_Complex : Fortran.Complex; + + TST_Imaginary_i : Fortran.Imaginary := FORTRAN.i; + TST_Imaginary_j : Fortran.Imaginary := FORTRAN.j; + + + -- Initialize it so we can use it below + TST_Character_Set : Fortran.Character_Set := + Fortran.Character_Set'First; + + TST_Fortran_Character : FORTRAN.Fortran_Character (1..5) := + (others => TST_Character_Set); + + + + begin -- encapsulation + + -- Arrange that the calls to the subprograms are compiled but + -- not executed + -- + if not Report.Equal ( TC_Int, TC_Int ) then + + TST_Character_Set := Fortran.To_Fortran (TC_Character); + TC_Character := Fortran.To_Ada (TST_Character_Set); + + + TST_Fortran_Character := FORTRAN.To_Fortran ("TEST STRING"); + Report.Comment ( Fortran.To_Ada (TST_Fortran_Character) ); + + Fortran.To_Fortran ( TC_String, TST_Fortran_Character, TC_Natural ); + Fortran.To_Ada ( TST_Fortran_Character, TC_String, TC_Natural ); + + end if; + + end; -- encapsulation + + Report.Result; + +end CXB5001; diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb5002.a b/gcc/testsuite/ada/acats/tests/cxb/cxb5002.a new file mode 100644 index 000000000..3da7cc9b1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb5002.a @@ -0,0 +1,334 @@ +-- CXB5002.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 the Function To_Fortran with a Character parameter will +-- return the corresponding Fortran Character_Set value. +-- +-- Check that the Function To_Ada with a Character_Set parameter will +-- return the corresponding Ada Character value. +-- +-- Check that the Function To_Fortran with a String parameter will +-- return the corresponding Fortran_Character value. +-- +-- Check that the Function To_Ada with a Fortran_Character parameter +-- will return the corresponding Ada String value. +-- +-- TEST DESCRIPTION: +-- This test checks that the functions To_Fortran and To_Ada produce +-- the correct results, based on a variety of parameter input values. +-- +-- In the first series of subtests, the results of the function +-- To_Fortran are compared against expected Character_Set type results. +-- In the second series of subtests, the results of the function To_Ada +-- are compared against expected String type results, and the length of +-- the String result is also verified against the Fortran_Character type +-- parameter. +-- +-- This test uses Fixed, Bounded, and Unbounded_Strings in combination +-- with the functions under validation. +-- +-- This test assumes that the following characters are all included +-- in the implementation defined type Interfaces.Fortran.Character_Set: +-- ' ', 'a'..'z', 'A'..'Z', '1'..'9', '-', '_', '$', '#', and '*'. +-- +-- APPLICABILITY CRITERIA: +-- This test is applicable to all implementations that provide +-- package Interfaces.Fortran. If an implementation provides +-- package Interfaces.Fortran, this test must compile, execute, and +-- report "PASSED". +-- +-- This test does not apply to an implementation in which the Fortran +-- character set ranges are not contiguous (e.g., EBCDIC). +-- +-- +-- +-- CHANGE HISTORY: +-- 11 Mar 96 SAIC Initial release for 2.1. +-- 10 Jun 96 SAIC Incorporated reviewer comments for ACVC 2.1. +-- 27 Oct 96 SAIC Incorporated reviewer comments. +-- +--! + +with Ada.Characters.Latin_1; +with Ada.Exceptions; +with Ada.Strings.Bounded; +with Ada.Strings.Unbounded; +with Ada.Unchecked_Conversion; +with Interfaces.Fortran; -- N/A => ERROR +with Report; + +procedure CXB5002 is +begin + + Report.Test ("CXB5002", "Check that functions To_Fortran and To_Ada " & + "produce correct results"); + + Test_Block: + declare + + package ACL renames Ada.Characters.Latin_1; + package Bnd is new Ada.Strings.Bounded.Generic_Bounded_Length(10); + package Unb renames Ada.Strings.Unbounded; + + use Bnd, Unb; + use Interfaces.Fortran; + use Ada.Exceptions; + + Null_Fortran_Character : constant Fortran_Character := ""; + Fortran_Character_1 : Fortran_Character(1..1) := " "; + Fortran_Character_5 : Fortran_Character(1..5) := " "; + Fortran_Character_10 : Fortran_Character(1..10) := " "; + Fortran_Character_20 : Fortran_Character(1..20) := + " "; + TC_Fortran_Character_1 : Fortran_Character(1..1) := "A"; + TC_Fortran_Character_5 : Fortran_Character(1..5) := "ab*de"; + TC_Fortran_Character_10 : Fortran_Character(1..10) := "$1a2b3C4D5"; + TC_Fortran_Character_20 : Fortran_Character(1..20) := + "1234-ABCD_6789#fghij"; + + Bnd_String : Bnd.Bounded_String := + Bnd.To_Bounded_String(" "); + TC_Bnd_String : Bounded_String := + To_Bounded_String("$1a2b3C4D5"); + + Unb_String : Unb.Unbounded_String := + Unb.To_Unbounded_String(" "); + TC_Unb_String : Unbounded_String := + To_Unbounded_String("ab*de"); + + String_1 : String(1..1) := " "; + String_5 : String(1..5) := " "; + String_10 : String(1..10) := " "; + String_20 : String(1..20) := " "; + TC_String_1 : String(1..1) := "A"; + TC_String_20 : String(1..20) := "1234-ABCD_6789#fghij"; + Null_String : constant String := ""; + + Null_Character : constant Character := ACL.Nul; + Character_A : constant Character := Character'Val(65); + Character_Z : constant Character := Character'Val(90); + TC_Character : Character := Character'First; + + Null_Character_Set : Character_Set := To_Fortran(ACL.Nul); + TC_Character_Set, + TC_Low_Character_Set, + TC_High_Character_Set : Character_Set := Character_Set'First; + + + -- The following procedure checks the results of function To_Ada. + + procedure Check_Length (Str : in String; + Ftn : in Fortran_Character; + Num : in Natural) is + begin + if Str'Length /= Ftn'Length or + Str'Length /= Num + then + Report.Failed("Incorrect result from Function To_Ada " & + "with string length " & Integer'Image(Num)); + end if; + end Check_Length; + + -- To facilitate the conversion of Character-Character_Set data, the + -- following functions have been instantiated. + + function Character_to_Character_Set is + new Ada.Unchecked_Conversion(Character, Character_Set); + + function Character_Set_to_Character is + new Ada.Unchecked_Conversion(Character_Set, Character); + + begin + + -- Check that the Function To_Fortran with a Character parameter + -- will return the corresponding Fortran Character_Set value. + + for TC_Character in ACL.LC_A..ACL.LC_Z loop + if To_Fortran(Item => TC_Character) /= + Character_to_Character_Set(TC_Character) + then + Report.Failed("Incorrect result from To_Fortran with lower " & + "case alphabetic character input"); + end if; + end loop; + + for TC_Character in Character_A..Character_Z loop + if To_Fortran(TC_Character) /= + Character_to_Character_Set(TC_Character) + then + Report.Failed("Incorrect result from To_Fortran with upper " & + "case alphabetic character input"); + end if; + end loop; + + if To_Fortran(Null_Character) /= + Character_to_Character_Set(Null_Character) + then + Report.Failed + ("Incorrect result from To_Fortran with null character input"); + end if; + + + -- Check that the Function To_Ada with a Character_Set parameter + -- will return the corresponding Ada Character value. + + TC_Low_Character_Set := Character_to_Character_Set('a'); + TC_High_Character_Set := Character_to_Character_Set('z'); + for TC_Character_Set in TC_Low_Character_Set..TC_High_Character_Set loop + if To_Ada(Item => TC_Character_Set) /= + Character_Set_to_Character(TC_Character_Set) + then + Report.Failed("Incorrect result from To_Ada with lower case " & + "alphabetic Character_Set input"); + end if; + end loop; + + TC_Low_Character_Set := Character_to_Character_Set('A'); + TC_High_Character_Set := Character_to_Character_Set('Z'); + for TC_Character_Set in TC_Low_Character_Set..TC_High_Character_Set loop + if To_Ada(TC_Character_Set) /= + Character_Set_to_Character(TC_Character_Set) + then + Report.Failed("Incorrect result from To_Ada with upper case " & + "alphabetic Character_Set input"); + end if; + end loop; + + if To_Ada(Character_to_Character_Set(Null_Character)) /= + Null_Character + then + Report.Failed("Incorrect result from To_Ada with a null " & + "Character_Set input"); + end if; + + + -- Check that the Function To_Fortran with a String parameter + -- will return the corresponding Fortran_Character value. + -- Note: The type Fortran_Character is a character array type that + -- corresponds to Ada type String. + + Fortran_Character_1 := To_Fortran(Item => TC_String_1); + + if Fortran_Character_1 /= TC_Fortran_Character_1 then + Report.Failed("Incorrect result from procedure To_Fortran - 1"); + end if; + + Fortran_Character_5 := To_Fortran(To_String(TC_Unb_String)); + + if Fortran_Character_5 /= TC_Fortran_Character_5 then + Report.Failed("Incorrect result from procedure To_Fortran - 2"); + end if; + + Fortran_Character_10 := To_Fortran(To_String(TC_Bnd_String)); + + if Fortran_Character_10 /= TC_Fortran_Character_10 then + Report.Failed("Incorrect result from procedure To_Fortran - 3"); + end if; + + Fortran_Character_20 := To_Fortran(Item => TC_String_20); + + if Fortran_Character_20 /= TC_Fortran_Character_20 then + Report.Failed("Incorrect result from procedure To_Fortran - 4"); + end if; + + if To_Fortran(Null_String) /= Null_Fortran_Character then + Report.Failed("Incorrect result from procedure To_Fortran - 5"); + end if; + + + -- Check that the Function To_Ada with a Fortran_Character parameter + -- will return the corresponding Ada String value. + + String_1 := To_Ada(TC_Fortran_Character_1); + + if String_1 /= TC_String_1 then + Report.Failed("Incorrect value returned from function To_Ada - 1"); + end if; + + Check_Length(To_Ada(TC_Fortran_Character_1), + TC_Fortran_Character_1, + Num => 1); + + + Unb_String := Unb.To_Unbounded_String(To_Ada(TC_Fortran_Character_5)); + + if Unb_String /= TC_Unb_String then + Report.Failed("Incorrect value returned from function To_Ada - 2"); + end if; + + Check_Length(To_Ada(TC_Fortran_Character_5), + TC_Fortran_Character_5, + Num => 5); + + + Bnd_String := Bnd.To_Bounded_String + (To_Ada(TC_Fortran_Character_10)); + + if Bnd_String /= TC_Bnd_String then + Report.Failed("Incorrect value returned from function To_Ada - 3"); + end if; + + Check_Length(To_Ada(TC_Fortran_Character_10), + TC_Fortran_Character_10, + Num => 10); + + + String_20 := To_Ada(TC_Fortran_Character_20); + + if String_20 /= TC_String_20 then + Report.Failed("Incorrect value returned from function To_Ada - 4"); + end if; + + Check_Length(To_Ada(TC_Fortran_Character_20), + TC_Fortran_Character_20, + Num => 20); + + if To_Ada(Null_Character_Set) /= Null_Character then + Report.Failed("Incorrect value returned from function To_Ada - 5"); + end if; + + + -- Check the two functions when used in combination. + + if To_Ada(Item => To_Fortran("This is a test")) /= + "This is a test" or + To_Ada(To_Fortran("1234567890abcdeFGHIJ")) /= + Report.Ident_Str("1234567890abcdeFGHIJ") + then + Report.Failed("Incorrect result returned when using the " & + "functions To_Ada and To_Fortran in combination"); + end if; + + + exception + when The_Error : others => + Report.Failed("The following exception was raised in the " & + "Test_Block: " & Exception_Name(The_Error)); + end Test_Block; + + Report.Result; + +end CXB5002; diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb5003.a b/gcc/testsuite/ada/acats/tests/cxb/cxb5003.a new file mode 100644 index 000000000..1c2b1c537 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb5003.a @@ -0,0 +1,295 @@ +-- CXB5003.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 the procedure To_Fortran converts the character elements +-- of the String parameter Item into Character_Set elements of the +-- Fortran_Character type parameter Target. Check that the parameter +-- Last contains the index of the last element of parameter Target +-- that was assigned by To_Fortran. +-- +-- Check that Constraint_Error is propagated by procedure To_Fortran +-- when the length of String parameter Item exceeds the length of +-- Fortran_Character parameter Target. +-- +-- Check that the procedure To_Ada converts the Character_Set +-- elements of the Fortran_Character parameter Item into Character +-- elements of the String parameter Target. Check that the parameter +-- Last contains the index of the last element of parameter Target +-- that was assigned by To_Ada. +-- +-- Check that Constraint_Error is propagated by procedure To_Ada when +-- the length of Fortran_Character parameter Item exceeds the length of +-- String parameter Target. +-- +-- TEST DESCRIPTION: +-- This test checks that the procedures To_Fortran and To_Ada produce +-- the correct results, based on a variety of parameter input values. +-- +-- In the first series of subtests, the Out parameter results of +-- procedure To_Fortran are compared against expected results, +-- which includes (in the parameter Last) the index in Target of the +-- last element assigned. The situation where procedure To_Fortran +-- raises Constraint_Error (when Item'Length exceeds Target'Length) +-- is also verified. +-- +-- In the second series of subtests, the Out parameter results of +-- procedure To_Ada are verified, in a similar manner as is done for +-- procedure To_Fortran. The case of procedure To_Ada raising +-- Constraint_Error is also verified. +-- +-- This test assumes that the following characters are all included +-- in the implementation defined type Interfaces.Fortran.Character_Set: +-- ' ', 'a'..'j', 'A'..'D', '1'..'9', '-', '_', '$', '#', and '*'. +-- +-- APPLICABILITY CRITERIA: +-- This test is applicable to all implementations that provide +-- package Interfaces.Fortran. If an implementation provides +-- package Interfaces.Fortran, this test must compile, execute, and +-- report "PASSED". +-- +-- +-- CHANGE HISTORY: +-- 14 Mar 96 SAIC Initial release for 2.1. +-- 10 Jun 96 SAIC Incorporated reviewer comments for ACVC 2.1. +-- 27 Oct 96 SAIC Incorporated reviewer comments. +-- +--! + +with Ada.Exceptions; +with Ada.Strings.Bounded; +with Ada.Strings.Unbounded; +with Interfaces.Fortran; -- N/A => ERROR +with Report; + +procedure CXB5003 is +begin + + Report.Test ("CXB5003", "Check that procedures To_Fortran and To_Ada " & + "produce correct results"); + + Test_Block: + declare + + package Bnd is new Ada.Strings.Bounded.Generic_Bounded_Length(10); + package Unb renames Ada.Strings.Unbounded; + + use Bnd, Unb; + use Interfaces.Fortran; + use Ada.Exceptions; + + Fortran_Character_1 : Fortran_Character(1..1) := " "; + Fortran_Character_5 : Fortran_Character(1..5) := " "; + Fortran_Character_10 : Fortran_Character(1..10) := " "; + Fortran_Character_20 : Fortran_Character(1..20) := + " "; + TC_Fortran_Character_1 : Fortran_Character(1..1) := "A"; + TC_Fortran_Character_5 : Fortran_Character(1..5) := "ab*de"; + TC_Fortran_Character_10 : Fortran_Character(1..10) := "$1a2b3C4D5"; + TC_Fortran_Character_20 : Fortran_Character(1..20) := + "1234-ABCD_6789#fghij"; + + Bnd_String : Bnd.Bounded_String := + Bnd.To_Bounded_String(" "); + TC_Bnd_String : Bounded_String := + To_Bounded_String("$1a2b3C4D5"); + + Unb_String : Unb.Unbounded_String := + Unb.To_Unbounded_String(" "); + TC_Unb_String : Unbounded_String := + To_Unbounded_String("ab*de"); + + String_1 : String(1..1) := " "; + String_5 : String(1..5) := " "; + String_10 : String(1..10) := " "; + String_20 : String(1..20) := " "; + TC_String_1 : String(1..1) := "A"; + TC_String_20 : String(1..20) := "1234-ABCD_6789#fghij"; + + TC_Fortran_Character : constant Fortran_Character := ""; + TC_String : constant String := ""; + TC_Natural : Natural := 0; + + + begin + + -- Check that the procedure To_Fortran converts the character elements + -- of the String parameter Item into Character_Set elements of the + -- Fortran_Character type parameter Target. + -- Check that the parameter Last contains the index of the last element + -- of parameter Target that was assigned by To_Fortran. + + To_Fortran(Item => TC_String_1, + Target => Fortran_Character_1, + Last => TC_Natural); + + if Fortran_Character_1 /= TC_Fortran_Character_1 or + TC_Natural /= TC_Fortran_Character_1'Length + then + Report.Failed("Incorrect result from procedure To_Fortran - 1"); + end if; + + To_Fortran(To_String(TC_Unb_String), + Target => Fortran_Character_5, + Last => TC_Natural); + + if Fortran_Character_5 /= TC_Fortran_Character_5 or + TC_Natural /= TC_Fortran_Character_5'Length + then + Report.Failed("Incorrect result from procedure To_Fortran - 2"); + end if; + + To_Fortran(To_String(TC_Bnd_String), + Fortran_Character_10, + Last => TC_Natural); + + if Fortran_Character_10 /= TC_Fortran_Character_10 or + TC_Natural /= TC_Fortran_Character_10'Length + then + Report.Failed("Incorrect result from procedure To_Fortran - 3"); + end if; + + To_Fortran(TC_String_20, Fortran_Character_20, TC_Natural); + + if Fortran_Character_20 /= TC_Fortran_Character_20 or + TC_Natural /= TC_Fortran_Character_20'Length + then + Report.Failed("Incorrect result from procedure To_Fortran - 4"); + end if; + + To_Fortran(Item => TC_String, -- null string + Target => Fortran_Character_1, + Last => TC_Natural); + + if TC_Natural /= 0 then + Report.Failed("Incorrect result from procedure To_Fortran, value " & + "returned in parameter Last should be zero, since " & + "parameter Item is null array"); + end if; + + + -- Check that Constraint_Error is propagated by procedure To_Fortran + -- when the length of String parameter Item exceeds the length of + -- Fortran_Character parameter Target. + + begin + + To_Fortran(Item => TC_String_20, + Target => Fortran_Character_10, + Last => TC_Natural); + Report.Failed("Constraint_Error not raised by procedure " & + "To_Fortran when Item'Length exceeds Target'Length"); + exception + when Constraint_Error => null; -- OK, expected exception. + when The_Error : others => + Report.Failed("The following exception was raised by procedure " & + "To_Fortran when Item'Length exceeds " & + "Target'Length: " & Exception_Name(The_Error)); + end; + + + -- Check that the procedure To_Ada converts the Character_Set + -- elements of the Fortran_Character parameter Item into Character + -- elements of the String parameter Target. + -- Check that the parameter Last contains the index of the last + -- element of parameter Target that was assigned by To_Ada. + + To_Ada(Item => TC_Fortran_Character_1, + Target => String_1, + Last => TC_Natural); + + if String_1 /= TC_String_1 or + TC_Natural /= TC_String_1'Length + then + Report.Failed("Incorrect result from procedure To_Ada - 1"); + end if; + + To_Ada(TC_Fortran_Character_5, + Target => String_5, + Last => TC_Natural); + + if String_5 /= To_String(TC_Unb_String) or + TC_Natural /= Length(TC_Unb_String) + then + Report.Failed("Incorrect result from procedure To_Ada - 2"); + end if; + + To_Ada(TC_Fortran_Character_10, + String_10, + Last => TC_Natural); + + if String_10 /= To_String(TC_Bnd_String) or + TC_Natural /= Length(TC_Bnd_String) + then + Report.Failed("Incorrect result from procedure To_Ada - 3"); + end if; + + To_Ada(TC_Fortran_Character_20, String_20, TC_Natural); + + if String_20 /= TC_String_20 or + TC_Natural /= TC_String_20'Length + then + Report.Failed("Incorrect result from procedure To_Ada - 4"); + end if; + + To_Ada(Item => TC_Fortran_Character, -- null array. + Target => String_20, + Last => TC_Natural); + + if TC_Natural /= 0 then + Report.Failed("Incorrect result from procedure To_Ada, value " & + "returned in parameter Last should be zero, since " & + "parameter Item is null array"); + end if; + + + -- Check that Constraint_Error is propagated by procedure To_Ada + -- when the length of Fortran_Character parameter Item exceeds the + -- length of String parameter Target. + + begin + + To_Ada(Item => TC_Fortran_Character_10, + Target => String_5, + Last => TC_Natural); + Report.Failed("Constraint_Error not raised by procedure To_Ada " & + "when Item'Length exceeds Target'Length"); + exception + when Constraint_Error => null; -- OK, expected exception. + when The_Error : others => + Report.Failed("Incorrect exception raised by procedure To_Ada " & + "when Item'Length exceeds Target'Length"); + end; + + + exception + when The_Error : others => + Report.Failed("The following exception was raised in the " & + "Test_Block: " & Exception_Name(The_Error)); + end Test_Block; + + Report.Result; + +end CXB5003; |