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