diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/cxb')
27 files changed, 0 insertions, 8423 deletions
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb2001.a b/gcc/testsuite/ada/acats/tests/cxb/cxb2001.a deleted file mode 100644 index 73f9209cd34..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxb/cxb2001.a +++ /dev/null @@ -1,633 +0,0 @@ --- 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 deleted file mode 100644 index 945722295e7..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxb/cxb2002.a +++ /dev/null @@ -1,259 +0,0 @@ --- 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 deleted file mode 100644 index ec3998ad875..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxb/cxb2003.a +++ /dev/null @@ -1,255 +0,0 @@ --- 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 deleted file mode 100644 index 4d79b24e1f3..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxb/cxb3001.a +++ /dev/null @@ -1,179 +0,0 @@ --- 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 deleted file mode 100644 index b543d467c46..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxb/cxb3002.a +++ /dev/null @@ -1,158 +0,0 @@ --- 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 deleted file mode 100644 index c395837489d..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxb/cxb3003.a +++ /dev/null @@ -1,167 +0,0 @@ --- 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/cxb3005.a b/gcc/testsuite/ada/acats/tests/cxb/cxb3005.a deleted file mode 100644 index 30b94053598..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxb/cxb3005.a +++ /dev/null @@ -1,396 +0,0 @@ --- 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/cxb3007.a b/gcc/testsuite/ada/acats/tests/cxb/cxb3007.a deleted file mode 100644 index 3837e0bae1f..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxb/cxb3007.a +++ /dev/null @@ -1,408 +0,0 @@ --- 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 deleted file mode 100644 index 9df19d814c3..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxb/cxb3008.a +++ /dev/null @@ -1,226 +0,0 @@ --- 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 deleted file mode 100644 index 3ea5a620442..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxb/cxb3009.a +++ /dev/null @@ -1,305 +0,0 @@ --- 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 deleted file mode 100644 index 25305b22fd0..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxb/cxb3010.a +++ /dev/null @@ -1,320 +0,0 @@ --- 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 deleted file mode 100644 index 6930407ec55..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxb/cxb3011.a +++ /dev/null @@ -1,282 +0,0 @@ --- 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 deleted file mode 100644 index 2f97e77871c..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxb/cxb3012.a +++ /dev/null @@ -1,342 +0,0 @@ --- 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). --- ---! - -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_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 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. - - 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.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.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.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.Failed("Incorrect result from Procedure Update - 8"); - end if; - 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/cxb3014.a b/gcc/testsuite/ada/acats/tests/cxb/cxb3014.a deleted file mode 100644 index a9b386ffcfd..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxb/cxb3014.a +++ /dev/null @@ -1,254 +0,0 @@ --- 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 deleted file mode 100644 index 24ec826fab9..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxb/cxb3015.a +++ /dev/null @@ -1,520 +0,0 @@ --- 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 deleted file mode 100644 index 362a062ad22..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxb/cxb3016.a +++ /dev/null @@ -1,516 +0,0 @@ --- 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 deleted file mode 100644 index 0c9ab1a6279..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxb/cxb4001.a +++ /dev/null @@ -1,230 +0,0 @@ --- 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 deleted file mode 100644 index e3934a5ef33..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxb/cxb4002.a +++ /dev/null @@ -1,308 +0,0 @@ --- 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 deleted file mode 100644 index 609dabc5089..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxb/cxb4003.a +++ /dev/null @@ -1,310 +0,0 @@ --- 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 deleted file mode 100644 index 0046c5e7c56..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxb/cxb4004.a +++ /dev/null @@ -1,443 +0,0 @@ --- 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 deleted file mode 100644 index 01f1ded1d1d..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxb/cxb4005.a +++ /dev/null @@ -1,332 +0,0 @@ --- 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 deleted file mode 100644 index 6e491eebff7..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxb/cxb4006.a +++ /dev/null @@ -1,322 +0,0 @@ --- 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 deleted file mode 100644 index c4e0641766a..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxb/cxb4007.a +++ /dev/null @@ -1,271 +0,0 @@ --- 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 deleted file mode 100644 index 5ab8e6b0339..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxb/cxb4008.a +++ /dev/null @@ -1,248 +0,0 @@ --- 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 deleted file mode 100644 index a681c5f13e2..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxb/cxb5001.a +++ /dev/null @@ -1,110 +0,0 @@ --- 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 deleted file mode 100644 index 3da7cc9b195..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxb/cxb5002.a +++ /dev/null @@ -1,334 +0,0 @@ --- 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 deleted file mode 100644 index 1c2b1c537ae..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxb/cxb5003.a +++ /dev/null @@ -1,295 +0,0 @@ --- 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; |