diff options
| author | upstream source tree <ports@midipix.org> | 2015-03-15 20:14:05 -0400 |
|---|---|---|
| committer | upstream source tree <ports@midipix.org> | 2015-03-15 20:14:05 -0400 |
| commit | 554fd8c5195424bdbcabf5de30fdc183aba391bd (patch) | |
| tree | 976dc5ab7fddf506dadce60ae936f43f58787092 /gcc/testsuite/ada/acats/tests/cxa | |
| download | cbb-gcc-4.6.4-554fd8c5195424bdbcabf5de30fdc183aba391bd.tar.bz2 cbb-gcc-4.6.4-554fd8c5195424bdbcabf5de30fdc183aba391bd.tar.xz | |
obtained gcc-4.6.4.tar.bz2 from upstream website;upstream
verified gcc-4.6.4.tar.bz2.sig;
imported gcc-4.6.4 source tree from verified upstream tarball.
downloading a git-generated archive based on the 'upstream' tag
should provide you with a source tree that is binary identical
to the one extracted from the above tarball.
if you have obtained the source via the command 'git clone',
however, do note that line-endings of files in your working
directory might differ from line-endings of the respective
files in the upstream repository.
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/cxa')
86 files changed, 31445 insertions, 0 deletions
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa3001.a b/gcc/testsuite/ada/acats/tests/cxa/cxa3001.a new file mode 100644 index 000000000..9c7e25b97 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa3001.a @@ -0,0 +1,507 @@ +-- CXA3001.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 character classification functions defined in +-- package Ada.Characters.Handling produce correct results when provided +-- constant arguments from package Ada.Characters.Latin_1. +-- +-- TEST DESCRIPTION: +-- This test checks the character classification functions of package +-- Ada.Characters.Handling. In the evaluation of each function, loops +-- are constructed to examine the function with as many values of type +-- Character (Ada.Characters.Latin_1 constants) as possible in an +-- amount of code that is about equal to the amount of code required +-- to examine the function with a few representative input values and +-- endpoint values. +-- The usage paradigm being demonstrated by this test is that of the +-- functions being used to assign to boolean variables, as well as +-- serving as boolean conditions. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 29 Apr 95 SAIC Fixed subtest checking Is_Graphic function. +-- +--! + +with Ada.Characters.Latin_1; +with Ada.Characters.Handling; +with Report; + +procedure CXA3001 is + +begin + + Report.Test ("CXA3001", "Check that the character classification " & + "functions defined in package " & + "Ada.Characters.Handling produce " & + "correct results when provided constant " & + "arguments from package Ada.Characters.Latin_1"); + + Test_Block: + declare + + package AC renames Ada.Characters; + package ACH renames Ada.Characters.Handling; + + TC_Boolean : Boolean := False; + + begin + + -- Over the next six statements/blocks of code, evaluate functions + -- Is_Control and Is_Graphic with control character and non-control + -- character values. + + for i in Character'Pos(AC.Latin_1.NUL) .. + Character'Pos(AC.Latin_1.US) loop + if not ACH.Is_Control(Character'Val(i)) then + Report.Failed ("Incorrect result from function Is_Control - 1"); + end if; + if ACH.Is_Graphic(Character'Val(i)) then + Report.Failed ("Incorrect result from function Is_Graphic - 1"); + end if; + end loop; + + + for i in Character'Pos(AC.Latin_1.Space) .. + Character'Pos(AC.Latin_1.Tilde) loop + if not ACH.Is_Graphic(Character'Val(i)) then + Report.Failed ("Incorrect result from function Is_Graphic - 2"); + end if; + if ACH.Is_Control(Character'Val(i)) then + Report.Failed ("Incorrect result from function Is_Control - 2"); + end if; + end loop; + + + for i in Character'Pos(AC.Latin_1.Reserved_128) .. + Character'Pos(AC.Latin_1.APC) loop + if not ACH.Is_Control(Character'Val(i)) then + Report.Failed ("Incorrect result from function Is_Control - 3"); + end if; + TC_Boolean := ACH.Is_Graphic(Character'Val(i)); + if TC_Boolean then + Report.Failed ("Incorrect result from function Is_Graphic - 3"); + TC_Boolean := False; + end if; + end loop; + + for i in Character'Pos(AC.Latin_1.No_Break_Space) .. + Character'Pos(AC.Latin_1.LC_Y_Diaeresis) loop + TC_Boolean := ACH.Is_Control(Character'Val(i)); + if TC_Boolean then + Report.Failed ("Incorrect result from function Is_Control - 4"); + TC_Boolean := False; + end if; + if not ACH.Is_Graphic(Character'Val(i)) then + Report.Failed ("Incorrect result from function Is_Graphic - 4"); + end if; + end loop; + + -- Check renamed constants. + + if not (ACH.Is_Control(AC.Latin_1.IS4) and + ACH.Is_Control(AC.Latin_1.IS3) and + ACH.Is_Control(AC.Latin_1.IS2) and + ACH.Is_Control(AC.Latin_1.IS1)) or + (ACH.Is_Control(AC.Latin_1.NBSP) or + ACH.Is_Control(AC.Latin_1.Paragraph_Sign) or + ACH.Is_Control(AC.Latin_1.Minus_Sign) or + ACH.Is_Control(AC.Latin_1.Ring_Above)) + then + Report.Failed ("Incorrect result from function Is_Control - 5"); + end if; + + if (ACH.Is_Graphic(AC.Latin_1.IS4) or + ACH.Is_Graphic(AC.Latin_1.IS3) or + ACH.Is_Graphic(AC.Latin_1.IS2) or + ACH.Is_Graphic(AC.Latin_1.IS1)) or + not (ACH.Is_Graphic(AC.Latin_1.NBSP) and + ACH.Is_Graphic(AC.Latin_1.Paragraph_Sign) and + ACH.Is_Graphic(AC.Latin_1.Minus_Sign) and + ACH.Is_Graphic(AC.Latin_1.Ring_Above)) + then + Report.Failed ("Incorrect result from function Is_Graphic - 5"); + end if; + + + -- Evaluate function Is_Letter with letter/non-letter inputs. + + for i in Character'Pos('A') .. Character'Pos('Z') loop + if not ACH.Is_Letter(Character'Val(i)) then + Report.Failed ("Incorrect Is_Letter result - 1"); + end if; + end loop; + + for i in Character'Pos(AC.Latin_1.LC_A) .. + Character'Pos(AC.Latin_1.LC_Z) loop + if not ACH.Is_Letter(Character'Val(i)) then + Report.Failed ("Incorrect Is_Letter result - 2"); + end if; + end loop; + + for i in Character'Pos(AC.Latin_1.UC_A_Grave) .. + Character'Pos(AC.Latin_1.UC_O_Diaeresis) loop + if not ACH.Is_Letter(Character'Val(i)) then + Report.Failed ("Incorrect Is_Letter result - 3"); + end if; + end loop; + + for i in Character'Pos(AC.Latin_1.UC_O_Oblique_Stroke) .. + Character'Pos(AC.Latin_1.LC_O_Diaeresis) loop + if not ACH.Is_Letter(Character'Val(i)) then + Report.Failed ("Incorrect Is_Letter result - 4"); + end if; + end loop; + + for i in Character'Pos(AC.Latin_1.LC_O_Oblique_Stroke) .. + Character'Pos(AC.Latin_1.LC_Y_Diaeresis) loop + if not ACH.Is_Letter(Character'Val(i)) then + Report.Failed ("Incorrect Is_Letter result - 5"); + end if; + end loop; + + -- Check for rejection of non-letters. + for i in Character'Pos(AC.Latin_1.NUL) .. + Character'Pos(AC.Latin_1.Commercial_At) loop + if ACH.Is_Letter(Character'Val(i)) then + Report.Failed ("Incorrect Is_Letter result - 6"); + end if; + end loop; + + + -- Evaluate function Is_Lower with lower case/non-lower case inputs. + + for i in Character'Pos(AC.Latin_1.LC_A) .. + Character'Pos(AC.Latin_1.LC_Z) loop + if not ACH.Is_Lower(Character'Val(i)) then + Report.Failed ("Incorrect Is_Lower result - 1"); + end if; + end loop; + + for i in Character'Pos(AC.Latin_1.LC_A_Grave) .. + Character'Pos(AC.Latin_1.LC_O_Diaeresis) loop + if not ACH.Is_Lower(Character'Val(i)) then + Report.Failed ("Incorrect Is_Lower result - 2"); + end if; + end loop; + + for i in Character'Pos(AC.Latin_1.LC_O_Oblique_Stroke) .. + Character'Pos(AC.Latin_1.LC_Y_Diaeresis) loop + if not ACH.Is_Lower(Character'Val(i)) then + Report.Failed ("Incorrect Is_Lower result - 3"); + end if; + end loop; + + if ACH.Is_Lower('A') or + ACH.Is_Lower(AC.Latin_1.UC_Icelandic_Eth) or + ACH.Is_Lower(AC.Latin_1.Number_Sign) or + ACH.Is_Lower(AC.Latin_1.Cedilla) or + ACH.Is_Lower(AC.Latin_1.SYN) or + ACH.Is_Lower(AC.Latin_1.ESA) + then + Report.Failed ("Incorrect Is_Lower result - 4"); + end if; + + + -- Evaluate function Is_Upper with upper case/non-upper case inputs. + + for i in Character'Pos('A') .. Character'Pos('Z') loop + if not ACH.Is_Upper(Character'Val(i)) then + Report.Failed ("Incorrect Is_Upper result - 1"); + end if; + end loop; + + for i in Character'Pos(AC.Latin_1.UC_A_Grave) .. + Character'Pos(AC.Latin_1.UC_O_Diaeresis) loop + if not ACH.Is_Upper(Character'Val(i)) then + Report.Failed ("Incorrect Is_Upper result - 2"); + end if; + end loop; + + for i in Character'Pos(AC.Latin_1.UC_O_Oblique_Stroke) .. + Character'Pos(AC.Latin_1.UC_Icelandic_Thorn) loop + if not ACH.Is_Upper(Character'Val(i)) then + Report.Failed ("Incorrect Is_Upper result - 3"); + end if; + end loop; + + if ACH.Is_Upper('8') or + ACH.Is_Upper(AC.Latin_1.LC_A_Ring ) or + ACH.Is_Upper(AC.Latin_1.Dollar_Sign) or + ACH.Is_Upper(AC.Latin_1.Broken_Bar) or + ACH.Is_Upper(AC.Latin_1.ETB) or + ACH.Is_Upper(AC.Latin_1.VTS) + then + Report.Failed ("Incorrect Is_Upper result - 4"); + end if; + + + for i in Character'Pos('a') .. Character'Pos('z') loop + if ACH.Is_Upper(Character'Val(i)) then + Report.Failed ("Incorrect Is_Upper result - 5"); + end if; + end loop; + + + -- Evaluate function Is_Basic with basic/non-basic inputs. + -- (Note: Basic letters are those without diacritical marks.) + + for i in Character'Pos('A') .. Character'Pos('Z') loop + if not ACH.Is_Basic(Character'Val(i)) then + Report.Failed ("Incorrect Is_Basic result - 1"); + end if; + end loop; + + for i in Character'Pos(AC.Latin_1.LC_A) .. + Character'Pos(AC.Latin_1.LC_Z) loop + if not ACH.Is_Basic(Character'Val(i)) then + Report.Failed ("Incorrect Is_Basic result - 2"); + end if; + end loop; + + + if not (ACH.Is_Basic(AC.Latin_1.UC_AE_Diphthong) and + ACH.Is_Basic(AC.Latin_1.LC_AE_Diphthong) and + ACH.Is_Basic(AC.Latin_1.LC_German_Sharp_S) and + ACH.Is_Basic(AC.Latin_1.LC_Icelandic_Eth) and + ACH.Is_Basic(AC.Latin_1.LC_Icelandic_Thorn) and + ACH.Is_Basic(AC.Latin_1.UC_Icelandic_Eth) and + ACH.Is_Basic(AC.Latin_1.UC_Icelandic_Thorn)) + then + Report.Failed ("Incorrect Is_Basic result - 3"); + end if; + + -- Check for rejection of non-basics. + if ACH.Is_Basic(AC.Latin_1.UC_A_Tilde) or + ACH.Is_Basic(AC.Latin_1.LC_A_Grave) or + ACH.Is_Basic(AC.Latin_1.Ampersand) or + ACH.Is_Basic(AC.Latin_1.Yen_Sign) or + ACH.Is_Basic(AC.Latin_1.NAK) or + ACH.Is_Basic(AC.Latin_1.SS2) + then + Report.Failed ("Incorrect Is_Basic result - 4"); + end if; + + + + for i in Character'Pos(AC.Latin_1.NUL) .. + Character'Pos(AC.Latin_1.Commercial_At) loop + if ACH.Is_Basic(Character'Val(i)) then + Report.Failed ("Incorrect Is_Basic result - 5"); + end if; + end loop; + + + -- Evaluate functions Is_Digit and Is_Decimal_Digit (a rename of + -- Is_Digit) with decimal digit/non-digit inputs. + + + if not (ACH.Is_Digit('0') and + ACH.Is_Decimal_Digit('9')) or + ACH.Is_Digit ('a') or -- Hex digits. + ACH.Is_Decimal_Digit ('f') or + ACH.Is_Decimal_Digit ('A') or + ACH.Is_Digit ('F') + then + Report.Failed ("Incorrect Is_Digit/Is_Decimal_Digit result - 1"); + end if; + + if ACH.Is_Digit (AC.Latin_1.Full_Stop) or + ACH.Is_Decimal_Digit (AC.Latin_1.Dollar_Sign) or + ACH.Is_Digit (AC.Latin_1.Number_Sign) or + ACH.Is_Decimal_Digit (AC.Latin_1.Left_Parenthesis) or + ACH.Is_Digit (AC.Latin_1.Right_Parenthesis) + then + Report.Failed ("Incorrect Is_Digit/Is_Decimal_Digit result - 2"); + end if; + + + -- Evaluate functions Is_Hexadecimal_Digit with hexadecimal digit and + -- non-hexadecimal digit inputs. + + for i in Character'Pos('0') .. Character'Pos('9') loop + if not ACH.Is_Hexadecimal_Digit(Character'Val(i)) then + Report.Failed ("Incorrect Is_Hexadecimal_Digit result - 1"); + end if; + end loop; + + for i in Character'Pos('A') .. Character'Pos('F') loop + if not ACH.Is_Hexadecimal_Digit(Character'Val(i)) then + Report.Failed ("Incorrect Is_Hexadecimal_Digit result - 2"); + end if; + end loop; + + for i in Character'Pos(AC.Latin_1.LC_A) .. + Character'Pos(AC.Latin_1.LC_F) loop + if not ACH.Is_Hexadecimal_Digit(Character'Val(i)) then + Report.Failed ("Incorrect Is_Hexadecimal_Digit result - 3"); + end if; + end loop; + + + if ACH.Is_Hexadecimal_Digit (AC.Latin_1.Minus_Sign) or + ACH.Is_Hexadecimal_Digit (AC.Latin_1.Hyphen) or + ACH.Is_Hexadecimal_Digit (AC.Latin_1.LC_G) or + ACH.Is_Hexadecimal_Digit (AC.Latin_1.LC_Z) or + ACH.Is_Hexadecimal_Digit ('G') or + ACH.Is_Hexadecimal_Digit (AC.Latin_1.Cent_Sign) or + ACH.Is_Hexadecimal_Digit (AC.Latin_1.Pound_Sign) + then + Report.Failed ("Incorrect Is_HexaDecimal_Digit result - 4"); + end if; + + + -- Evaluate functions Is_Alphanumeric and Is_Special with + -- letters, digits, and non-alphanumeric inputs. + + for i in Character'Pos(AC.Latin_1.NUL) .. + Character'Pos(AC.Latin_1.US) loop + if ACH.Is_Alphanumeric(Character'Val(i)) then + Report.Failed ("Incorrect Is_Alphanumeric result - 1"); + end if; + TC_Boolean := ACH.Is_Special(Character'Val(i)); + if TC_Boolean then + Report.Failed ("Incorrect Is_Special result - 1"); + TC_Boolean := False; + end if; + end loop; + + for i in Character'Pos(AC.Latin_1.Reserved_128) .. + Character'Pos(AC.Latin_1.APC) loop + TC_Boolean := ACH.Is_Alphanumeric(Character'Val(i)); + if TC_Boolean then + Report.Failed ("Incorrect Is_Alphanumeric result - 2"); + TC_Boolean := False; + end if; + if ACH.Is_Special(Character'Val(i)) then + Report.Failed ("Incorrect Is_Special result - 2"); + end if; + end loop; + + for i in Character'Pos(AC.Latin_1.Space) .. + Character'Pos(AC.Latin_1.Solidus) loop + TC_Boolean := ACH.Is_Alphanumeric(Character'Val(i)); + if TC_Boolean then + Report.Failed ("Incorrect Is_Alphanumeric result - 3"); + TC_Boolean := False; + end if; + if not ACH.Is_Special(Character'Val(i)) then + Report.Failed ("Incorrect Is_Special result - 3"); + end if; + end loop; + + for i in Character'Pos('A') .. Character'Pos('Z') loop + if not ACH.Is_Alphanumeric(Character'Val(i)) then + Report.Failed ("Incorrect Is_Alphanumeric result - 4"); + end if; + TC_Boolean := ACH.Is_Special(Character'Val(i)); + if TC_Boolean then + Report.Failed ("Incorrect Is_Special result - 4"); + TC_Boolean := False; + end if; + end loop; + + for i in Character'Pos('0') .. Character'Pos('9') loop + if not ACH.Is_Alphanumeric(Character'Val(i)) then + Report.Failed ("Incorrect Is_Alphanumeric result - 5"); + end if; + TC_Boolean := ACH.Is_Special(Character'Val(i)); + if TC_Boolean then + Report.Failed ("Incorrect Is_Special result - 5"); + TC_Boolean := False; + end if; + end loop; + + for i in Character'Pos(AC.Latin_1.LC_A) .. + Character'Pos(AC.Latin_1.LC_Z) loop + if not ACH.Is_Alphanumeric(Character'Val(i)) then + Report.Failed ("Incorrect Is_Alphanumeric result - 6"); + end if; + TC_Boolean := ACH.Is_Special(Character'Val(i)); + if TC_Boolean then + Report.Failed ("Incorrect Is_Special result - 6"); + TC_Boolean := False; + end if; + end loop; + + for i in Character'Pos(AC.Latin_1.No_Break_Space) .. + Character'Pos(AC.Latin_1.Inverted_Question) loop + TC_Boolean := ACH.Is_Alphanumeric(Character'Val(i)); + if TC_Boolean then + Report.Failed ("Incorrect Is_Alphanumeric result - 7"); + TC_Boolean := False; + end if; + if not ACH.Is_Special(Character'Val(i)) then + Report.Failed ("Incorrect Is_Special result - 7"); + end if; + end loop; + + for i in Character'Pos(AC.Latin_1.UC_A_Grave) .. + Character'Pos(AC.Latin_1.UC_O_Diaeresis) loop + if not ACH.Is_Alphanumeric(Character'Val(i)) then + Report.Failed ("Incorrect Is_Alphanumeric result - 8"); + end if; + TC_Boolean := ACH.Is_Special(Character'Val(i)); + if TC_Boolean then + Report.Failed ("Incorrect Is_Special result - 8"); + TC_Boolean := False; + end if; + end loop; + + for i in Character'Pos(AC.Latin_1.UC_O_Oblique_Stroke) .. + Character'Pos(AC.Latin_1.LC_O_Diaeresis) loop + if not ACH.Is_Alphanumeric(Character'Val(i)) then + Report.Failed ("Incorrect Is_Alphanumeric result - 9"); + end if; + TC_Boolean := ACH.Is_Special(Character'Val(i)); + if TC_Boolean then + Report.Failed ("Incorrect Is_Special result - 9"); + TC_Boolean := False; + end if; + end loop; + + for i in Character'Pos(AC.Latin_1.LC_O_Oblique_Stroke) .. + Character'Pos(AC.Latin_1.LC_Y_Diaeresis) loop + if not ACH.Is_Alphanumeric(Character'Val(i)) then + Report.Failed ("Incorrect Is_Alphanumeric result - 10"); + end if; + TC_Boolean := ACH.Is_Special(Character'Val(i)); + if TC_Boolean then + Report.Failed ("Incorrect Is_Special result - 10"); + TC_Boolean := False; + end if; + end loop; + + + exception + when others => Report.Failed ("Exception raised during processing"); + end Test_Block; + + + Report.Result; + +end CXA3001; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa3002.a b/gcc/testsuite/ada/acats/tests/cxa/cxa3002.a new file mode 100644 index 000000000..12d98fdfe --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa3002.a @@ -0,0 +1,318 @@ +-- CXA3002.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 conversion functions for Characters and Strings +-- defined in package Ada.Characters.Handling provide correct results +-- when given character/string input parameters. +-- +-- TEST DESCRIPTION: +-- This test checks the output of the To_Lower, To_Upper, and +-- To_Basic functions for both Characters and Strings. Each function +-- is called with input parameters that are within the appropriate +-- range of values, and also with values outside the specified +-- range (i.e., lower case 'a' to To_Lower). The functions are also +-- used in combination with one another, with the result of one function +-- providing the actual input parameter value to another. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 22 Dec 94 SAIC Corrected evaluations of Functions In Combination. +-- +--! + +with Ada.Characters.Latin_1; +with Ada.Characters.Handling; +with Report; + +procedure CXA3002 is + + package AC renames Ada.Characters; + package ACH renames Ada.Characters.Handling; + +begin + + Report.Test ("CXA3002", "Check that the conversion functions for " & + "Characters and Strings defined in package " & + "Ada.Characters.Handling provide correct " & + "results when given character/string input " & + "parameters"); + + + Character_Block: + declare + Offset : constant Integer := Character'Pos('a') - Character'Pos('A'); + begin + + -- Function To_Lower for Characters + + if ACH.To_Lower('A') /= 'a' or ACH.To_Lower('Z') /= 'z' then + Report.Failed ("Incorrect operation of function To_Lower - 1"); + end if; + + + for i in Character'Pos('A') .. Character'Pos('Z') loop + if ACH.To_Lower(Character'Val(i)) /= Character'Val(i + Offset) then + Report.Failed ("Incorrect operation of function To_Lower - 2"); + end if; + end loop; + + + if (ACH.To_Lower(AC.Latin_1.UC_A_Grave) /= + AC.Latin_1.LC_A_Grave) or + (ACH.To_Lower(AC.Latin_1.UC_Icelandic_Thorn) /= + AC.Latin_1.LC_Icelandic_Thorn) + then + Report.Failed ("Incorrect operation of function To_Lower - 3"); + end if; + + + if ACH.To_Lower('c') /= 'c' or + ACH.To_Lower('w') /= 'w' or + ACH.To_Lower(AC.Latin_1.CR) /= AC.Latin_1.CR or + ACH.To_Lower(AC.Latin_1.LF) /= AC.Latin_1.LF or + ACH.To_Lower(AC.Latin_1.Comma) /= AC.Latin_1.Comma or + ACH.To_Lower(AC.Latin_1.Question) /= AC.Latin_1.Question or + ACH.To_Lower('0') /= '0' or + ACH.To_Lower('9') /= '9' + then + Report.Failed ("Incorrect operation of function To_Lower - 4"); + end if; + + + --- Function To_Upper for Characters + + + if not (ACH.To_Upper('b') = 'B') and (ACH.To_Upper('y') = 'Y') then + Report.Failed ("Incorrect operation of function To_Upper - 1"); + end if; + + + for i in Character'Pos(AC.Latin_1.LC_A) .. + Character'Pos(AC.Latin_1.LC_Z) loop + if ACH.To_Upper(Character'Val(i)) /= Character'Val(i - Offset) then + Report.Failed ("Incorrect operation of function To_Upper - 2"); + end if; + end loop; + + + if (ACH.To_Upper(AC.Latin_1.LC_U_Diaeresis) /= + AC.Latin_1.UC_U_Diaeresis) or + (ACH.To_Upper(AC.Latin_1.LC_A_Ring) /= + AC.Latin_1.UC_A_Ring) + then + Report.Failed ("Incorrect operation of function To_Upper - 3"); + end if; + + + if not (ACH.To_Upper('F') = 'F' and + ACH.To_Upper('U') = 'U' and + ACH.To_Upper(AC.Latin_1.LC_German_Sharp_S) = + AC.Latin_1.LC_German_Sharp_S and + ACH.To_Upper(AC.Latin_1.LC_Y_Diaeresis) = + AC.Latin_1.LC_Y_Diaeresis) + then + Report.Failed ("Incorrect operation of function To_Upper - 4"); + end if; + + + --- Function To_Basic for Characters + + + if ACH.To_Basic(AC.Latin_1.LC_A_Circumflex) /= + ACH.To_Basic(AC.Latin_1.LC_A_Tilde) or + ACH.To_Basic(AC.Latin_1.LC_E_Grave) /= + ACH.To_Basic(AC.Latin_1.LC_E_Acute) or + ACH.To_Basic(AC.Latin_1.LC_I_Circumflex) /= + ACH.To_Basic(AC.Latin_1.LC_I_Diaeresis) or + ACH.To_Basic(AC.Latin_1.UC_O_Tilde) /= + ACH.To_Basic(AC.Latin_1.UC_O_Acute) or + ACH.To_Basic(AC.Latin_1.UC_U_Grave) /= + ACH.To_Basic(AC.Latin_1.UC_U_Acute) or + ACH.To_Basic(AC.Latin_1.LC_Y_Acute) /= + ACH.To_Basic(AC.Latin_1.LC_Y_Diaeresis) + then + Report.Failed ("Incorrect operation of function To_Basic - 1"); + end if; + + + if ACH.To_Basic('Y') /= 'Y' or + ACH.To_Basic(AC.Latin_1.LC_E_Acute) /= 'e' or + ACH.To_Basic('6') /= '6' or + ACH.To_Basic(AC.Latin_1.LC_R) /= 'r' + then + Report.Failed ("Incorrect operation of function To_Basic - 2"); + end if; + + + -- Using Functions (for Characters) in Combination + + + if (ACH.To_Upper(ACH.To_Lower('A')) /= 'A' ) or + (ACH.To_Upper(ACH.To_Lower(AC.Latin_1.UC_A_Acute)) /= + AC.Latin_1.UC_A_Acute ) + then + Report.Failed("Incorrect operation of functions in combination - 1"); + end if; + + + if ACH.To_Basic(ACH.To_Lower(ACH.To_Upper(AC.Latin_1.LC_U_Grave))) /= + 'u' + then + Report.Failed("Incorrect operation of functions in combination - 2"); + end if; + + + if ACH.To_Lower (ACH.To_Basic + (ACH.To_Upper(AC.Latin_1.LC_O_Diaeresis))) /= 'o' + then + Report.Failed("Incorrect operation of functions in combination - 3"); + end if; + + + exception + when others => Report.Failed ("Exception raised in Character_Block"); + end Character_Block; + + + String_Block: + declare + + LC_String : constant String := "az" & + AC.Latin_1.LC_A_Grave & + AC.Latin_1.LC_C_Cedilla; + + UC_String : constant String := "AZ" & + AC.Latin_1.UC_A_Grave & + AC.Latin_1.UC_C_Cedilla; + + LC_Basic_String : constant String := "aei" & 'o' & 'u'; + + LC_NonBasic_String : constant String := AC.Latin_1.LC_A_Diaeresis & + AC.Latin_1.LC_E_Circumflex & + AC.Latin_1.LC_I_Acute & + AC.Latin_1.LC_O_Tilde & + AC.Latin_1.LC_U_Grave; + + UC_Basic_String : constant String := "AEIOU"; + + UC_NonBasic_String : constant String := AC.Latin_1.UC_A_Tilde & + AC.Latin_1.UC_E_Acute & + AC.Latin_1.UC_I_Grave & + AC.Latin_1.UC_O_Diaeresis & + AC.Latin_1.UC_U_Circumflex; + + LC_Special_String : constant String := "ab" & + AC.Latin_1.LC_German_Sharp_S & + AC.Latin_1.LC_Y_Diaeresis; + + UC_Special_String : constant String := "AB" & + AC.Latin_1.LC_German_Sharp_S & + AC.Latin_1.LC_Y_Diaeresis; + + begin + + -- Function To_Lower for Strings + + + if ACH.To_Lower (UC_String) /= LC_String or + ACH.To_Lower (LC_String) /= LC_String + then + Report.Failed ("Incorrect result from To_Lower for strings - 1"); + end if; + + + if ACH.To_Lower (UC_Basic_String) /= LC_Basic_String then + Report.Failed ("Incorrect result from To_Lower for strings - 2"); + end if; + + + -- Function To_Upper for Strings + + + if not (ACH.To_Upper (LC_String) = UC_String) then + Report.Failed ("Incorrect result from To_Upper for strings - 1"); + end if; + + + if ACH.To_Upper (LC_Basic_String) /= UC_Basic_String or + ACH.To_Upper (UC_String) /= UC_String + then + Report.Failed ("Incorrect result from To_Upper for strings - 2"); + end if; + + + if ACH.To_Upper (LC_Special_String) /= UC_Special_String then + Report.Failed ("Incorrect result from To_Upper for strings - 3"); + end if; + + + + -- Function To_Basic for Strings + + + if (ACH.To_Basic (LC_String) /= "azac") or + (ACH.To_Basic (UC_String) /= "AZAC") + then + Report.Failed ("Incorrect result from To_Basic for Strings - 1"); + end if; + + + if ACH.To_Basic (LC_NonBasic_String) /= LC_Basic_String then + Report.Failed ("Incorrect result from To_Basic for Strings - 2"); + end if; + + + if ACH.To_Basic (UC_NonBasic_String) /= UC_Basic_String then + Report.Failed ("Incorrect result from To_Basic for Strings - 3"); + end if; + + + -- Using Functions (for Strings) in Combination + + + if ACH.To_Upper(ACH.To_Lower(UC_Basic_String)) /= UC_Basic_String or + ACH.To_Lower(ACH.To_Upper(LC_Basic_String)) /= LC_Basic_String + then + Report.Failed ("Incorrect operation of functions in combination - 4"); + end if; + + + if (ACH.To_Basic(ACH.To_Lower(UC_NonBasic_String)) /= LC_Basic_String) or + (ACH.To_Basic(ACH.To_Upper(LC_NonBasic_String)) /= UC_Basic_String) + then + Report.Failed ("Incorrect operation of functions in combination - 5"); + end if; + + + exception + when others => Report.Failed ("Exception raised in String_Block"); + end String_Block; + + + Report.Result; + +end CXA3002; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa3003.a b/gcc/testsuite/ada/acats/tests/cxa/cxa3003.a new file mode 100644 index 000000000..f469ef8b5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa3003.a @@ -0,0 +1,243 @@ +-- CXA3003.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 functions defined in package Ada.Characters.Handling +-- for use in classifying and converting characters between the ISO 646 +-- and type Character sets produce the correct results with both +-- Character and String input values. +-- +-- TEST DESCRIPTION: +-- This test is designed to exercise the classification and conversion +-- functions (between Character and ISO_646 types) found in package +-- Ada.Characters.Handling. Two subprograms are defined, a procedure for +-- characters, a function for strings, that will utilize these functions +-- to validate and change characters in variables. In the procedure, if +-- a character argument is found to be outside the subtype ISO_646, this +-- character is evaluated to determine whether it is also a letter. +-- If it is a letter, the character is converted to a basic character and +-- returned. If it is not a letter, the character is exchanged with an +-- asterisk. In the case of the function subprogram designed for strings, +-- if a character component of a string argument is outside the subtype +-- ISO_646, that character is substituted with an asterisk. +-- +-- Arguments for the defined subprograms consist of ISO_646 characters, +-- non-ISO_646 characters, strings with only ISO_646 characters, and +-- strings with non-ISO_646 characters. The character and string values +-- are then validated to determine that the expected results were +-- obtained. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 29 Apr 95 SAIC Modified identifier string lengths. +-- 31 Oct 95 SAIC Update and repair for ACVC 2.0.1. +-- +--! + +with Ada.Characters.Latin_1; +with Ada.Characters.Handling; +with Report; + +procedure CXA3003 is + +begin + + Report.Test ("CXA3003", "Check that the functions defined in package " & + "Ada.Characters.Handling for use in " & + "classifying and converting characters " & + "between the ISO 646 and type Character sets " & + "produce the correct results with both " & + "Character and String input values" ); + + Test_Block: + declare + + -- ISO_646 Characters + + Char_1, + TC_Char_1 : Character := Ada.Characters.Latin_1.NUL; -- Control Char + Char_2, + TC_Char_2 : Character := Ada.Characters.Latin_1.Colon; -- Graphic Char + Char_3, + TC_Char_3 : Character := '4'; + Char_4, + TC_Char_4 : Character := 'Z'; + Char_5, + TC_Char_5 : Character := Ada.Characters.Latin_1.LC_W; -- w + + New_ISO_646_Char : Character := '*'; + + + -- Non-ISO_646 Characters + + Char_Array : array (6..10) of Character := + (Ada.Characters.Latin_1.SSA, + Ada.Characters.Latin_1.Cent_Sign, + Ada.Characters.Latin_1.Cedilla, + Ada.Characters.Latin_1.UC_A_Ring, + Ada.Characters.Latin_1.LC_A_Ring); + + TC_Char : constant Character := '*'; + + -- ISO_646 Strings + + Str_1, + TC_Str_1 : String (1..5) := "ABCDE"; + + Str_2, + TC_Str_2 : String (1..5) := "#$%^&"; + + + -- Non-ISO_646 Strings + + Str_3 : String (1..8) := "$123.45" & + Ada.Characters.Latin_1.Cent_Sign; + TC_Str_3 : String (1..8) := "$123.45*"; + + Str_4 : String (1..7) := "abc" & + Ada.Characters.Latin_1.Cedilla & + "efg"; + TC_Str_4 : String (1..7) := "abc*efg"; + + Str_5 : String (1..3) := Ada.Characters.Latin_1.LC_E_Grave & + Ada.Characters.Latin_1.LC_T & + Ada.Characters.Latin_1.LC_E_Acute; + TC_Str_5 : String (1..3) := "*t*"; + + --- + + procedure Validate_Character (Char : in out Character) is + -- If parameter Char is an ISO_646 character, Char will be returned, + -- otherwise the following constant will be returned. + Star : constant Ada.Characters.Handling.ISO_646 := + Ada.Characters.Latin_1.Asterisk; + begin + if Ada.Characters.Handling.Is_ISO_646(Char) then + -- Check that the Is_ISO_646 function provide a correct result. + if Character'Pos(Char) > 127 then + Report.Failed("Is_ISO_646 returns a false positive result"); + end if; + else + if Character'Pos(Char) < 128 then + Report.Failed("Is_ISO_646 returns a false negative result"); + end if; + end if; + -- Cross-check Is_ISO_646 with To_ISO_646. '*' will be returned + -- if Char is not in the ISO_646 set. + Char := Ada.Characters.Handling.To_ISO_646(Char, Star); + exception + when others => Report.Failed ("Exception in Validate_Character"); + end Validate_Character; + + --- + + function Validate_String (Str : String) return String is + New_ISO_646_Char : constant Ada.Characters.Handling.ISO_646 := + Ada.Characters.Latin_1.Asterisk; + begin + -- Checking that the string contains non-ISO_646 characters at this + -- point is not strictly necessary, since the function To_ISO_646 + -- will perform that check as part of its processing, and would + -- return the original string if no modification were necessary. + -- However, this format allows for the testing of both functions. + + if not Ada.Characters.Handling.Is_ISO_646(Str) then + return Ada.Characters.Handling.To_ISO_646 + (Item => Str, Substitute => New_ISO_646_Char); + else + return Str; + end if; + exception + when others => Report.Failed ("Exception in Validate_String"); + return Str; + end Validate_String; + + + begin + + -- Check each character in turn, and if the character does not belong + -- to the ISO_646 subset of type Character, replace it with an + -- asterisk. If the character is a member of the subset, the character + -- should be returned unchanged. + + Validate_Character (Char_1); + Validate_Character (Char_2); + Validate_Character (Char_3); + Validate_Character (Char_4); + Validate_Character (Char_5); + + if Char_1 /= TC_Char_1 or Char_2 /= TC_Char_2 or + Char_3 /= TC_Char_3 or Char_4 /= TC_Char_4 or + Char_5 /= TC_Char_5 + then + Report.Failed ("Incorrect ISO_646 character substitution"); + end if; + + -- Non-ISO_646 characters + + for i in 6..10 loop + Validate_Character (Char_Array(i)); + end loop; + + for i in 6..10 loop + if Char_Array(i) /= TC_Char then + Report.Failed ("Character position " & Integer'Image(i) & + " not replaced correctly"); + end if; + end loop; + + + + -- Check each string, and if the string contains characters that do not + -- belong to the ISO_646 subset of type Character, replace that character + -- in the string with an asterisk. If the string is comprised of only + -- ISO_646 characters, the string should be returned unchanged. + + + Str_1 := Validate_String (Str_1); + Str_2 := Validate_String (Str_2); + Str_3 := Validate_String (Str_3); + Str_4 := Validate_String (Str_4); + Str_5 := Validate_String (Str_5); + + + if Str_1 /= TC_Str_1 or + Str_2 /= TC_Str_2 or + Str_3 /= TC_Str_3 or + Str_4 /= TC_Str_4 or + Str_5 /= TC_Str_5 + then + Report.Failed ("Incorrect ISO_646 character substitution in string"); + end if; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + +end CXA3003; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4001.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4001.a new file mode 100644 index 000000000..d850acd4a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4001.a @@ -0,0 +1,218 @@ +-- CXA4001.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 types, operations, and other entities defined within +-- the package Ada.Strings.Maps are available and/or produce correct +-- results. +-- +-- TEST DESCRIPTION: +-- This test demonstrates the availability and function of the types and +-- operations defined in package Ada.Strings.Maps. It demonstrates the +-- use of these types and functions as they would be used in common +-- programming practice. +-- Character set creation, assignment, and comparison are evaluated +-- in this test. Each of the functions provided in package +-- Ada.Strings.Maps is utilized in creating or manipulating set objects, +-- and the function results are evaluated for correctness. +-- Character sequences are examined using the functions provided for +-- manipulating objects of this type. Likewise, character maps are +-- created, and their contents evaluated. Exception raising conditions +-- from the function To_Mapping are also created. +-- Note: Throughout this test, the set logical operators are printed in +-- capital letters to enhance their visibility. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +with Ada.Strings.Maps; +with Report; + +procedure CXA4001 is + + use Ada.Strings; + use type Maps.Character_Set; + +begin + + Report.Test ("CXA4001", "Check that the types, operations, and other " & + "entities defined within the package " & + "Ada.Strings.Maps are available and/or produce " & + "correct results"); + + Test_Block: + declare + + MidPoint_Letter : constant := 13; + Last_Letter : constant := 26; + + Vowels : constant Maps.Character_Sequence := "aeiou"; + Quasi_Vowel : constant Character := 'y'; + + Alphabet : Maps.Character_Sequence (1..Last_Letter); + Half_Alphabet : Maps.Character_Sequence (1..MidPoint_Letter); + Inverse_Alphabet : Maps.Character_Sequence (1..Last_Letter); + + Alphabet_Set, + Consonant_Set, + Vowel_Set, + Full_Vowel_Set, + First_Half_Set, + Second_Half_Set : Maps.Character_Set; + + begin + + -- Load the alphabet string for use in creating sets. + + + for i in 0..12 loop + Half_Alphabet(i+1) := Character'Val(Character'Pos('a') + i); + end loop; + + for i in 0..25 loop + Alphabet(i+1) := Character'Val(Character'Pos('a') + i); + end loop; + + + -- Initialize a series of Character_Set objects. + + Alphabet_Set := Maps.To_Set(Alphabet); + Vowel_Set := Maps.To_Set(Vowels); + Full_Vowel_Set := Vowel_Set OR Maps.To_Set(Quasi_Vowel); + Consonant_Set := Vowel_Set XOR Alphabet_Set; + + First_Half_Set := Maps.To_Set(Half_Alphabet); + Second_Half_Set := Alphabet_Set XOR First_Half_Set; + + + -- Evaluation of Set objects, operators, and functions. + + if Alphabet_Set /= (Vowel_Set OR Consonant_Set) then + Report.Failed("Incorrect set combinations using OR operator"); + end if; + + + for i in 1..5 loop + if not Maps.Is_In(Vowels(i), Vowel_Set) or + not Maps.Is_In(Vowels(i), Alphabet_Set) or + Maps.Is_In(Vowels(i), Consonant_Set) + then + Report.Failed("Incorrect function Is_In use with set " & + "combinations - " & Integer'Image(i)); + end if; + end loop; + + + if Maps.Is_Subset(Vowel_Set, First_Half_Set) or + Maps."<="(Vowel_Set, Second_Half_Set) or + not Maps.Is_Subset(Vowel_Set, Alphabet_Set) + then + Report.Failed("Incorrect set evaluation using Is_Subset function"); + end if; + + + if not (Full_Vowel_Set = Maps.To_Set("aeiouy")) then + Report.Failed("Incorrect result for ""="" set operator"); + end if; + + + if not ((Vowel_Set AND First_Half_Set) OR + (Full_Vowel_Set AND Second_Half_Set)) = Full_Vowel_Set then + Report.Failed + ("Incorrect result for AND, OR, or ""="" set operators"); + end if; + + + if (Alphabet_Set AND Maps.Null_Set) /= Maps.Null_Set or + (Alphabet_Set OR Maps.Null_Set) /= Alphabet_Set + then + Report.Failed("Incorrect result for AND or OR set operators"); + end if; + + + Vowel_Set := Full_Vowel_Set; + Vowel_Set := Vowel_Set AND (NOT Maps.To_Set(Quasi_Vowel)); + + if not (Vowels = Maps.To_Sequence(Vowel_Set)) then + Report.Failed("Incorrect Set to Sequence translation"); + end if; + + + for i in 1..26 loop + Inverse_Alphabet(i) := Alphabet(27-i); + end loop; + + declare + Inverse_Map : Maps.Character_Mapping := + Maps.To_Mapping(Alphabet, Inverse_Alphabet); + begin + if Maps.Value(Maps.Identity, 'b') /= Maps.Value(Inverse_Map,'y') + then + Report.Failed("Incorrect Inverse mapping"); + end if; + end; + + + -- Check that Translation_Error is raised when a character is + -- repeated in the parameter "From" string. + declare + Bad_Map : Maps.Character_Mapping; + begin + Bad_Map := Maps.To_Mapping(From => "aa", To => "yz"); + Report.Failed("Exception not raised with repeated character"); + exception + when Translation_Error => null; -- OK + when others => + Report.Failed("Incorrect exception raised in To_Mapping with " & + "a repeated character"); + end; + + + -- Check that Translation_Error is raised when the parameters of the + -- function To_Mapping are of unequal lengths. + declare + Bad_Map : Maps.Character_Mapping; + begin + Bad_Map := Maps.To_Mapping("abc", "yz"); + Report.Failed("Exception not raised with unequal parameter lengths"); + exception + when Translation_Error => null; -- OK + when others => + Report.Failed("Incorrect exception raised in To_Mapping with " & + "unequal parameter lengths"); + end; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + + Report.Result; + +end CXA4001; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4002.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4002.a new file mode 100644 index 000000000..583621ab4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4002.a @@ -0,0 +1,182 @@ +-- CXA4002.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 subprograms defined in package Ada.Strings.Fixed are +-- available, and that they produce correct results. Specifically, +-- check the subprograms Index, "*" (string constructor function), +-- Count, Trim, and Replace_Slice. +-- +-- TEST DESCRIPTION: +-- This test demonstrates how certain Fixed string functions are used +-- to eliminate specific substrings from portions of text. A procedure +-- is defined that will take as parameters a source string along with +-- a substring that is to be completely removed from the source string. +-- The source string is parsed using the Index function, and any substring +-- slices are replaced in the source string by a series of X's (based on +-- the length of the substring.) +-- Three lines of text are provided to this procedure, and the resulting +-- substitutions are compared with expected results to validate the +-- string processing. +-- A global accumulator is updated with the number of occurrences of the +-- substring in the source string. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +with Ada.Strings; +with Ada.Strings.Fixed; +with Ada.Strings.Maps; +with Report; + +procedure CXA4002 is + +begin + + Report.Test ("CXA4002", "Check that the subprograms defined in package " & + "Ada.Strings.Fixed are available, and that " & + "they produce correct results"); + + Test_Block: + declare + + TC_Total : Natural := 0; + Number_Of_Lines : constant := 3; + + type Restricted_Words_Array_Type is array (1..10) of String (1..10); + + Restricted_Words : Restricted_Words_Array_Type := + (" platoon", " marines ", " Marines ", + "north ", "south ", " east", + " beach ", " airport", "airfield ", + " road "); + + subtype Line_Of_Text_Type is String(1..25); + type Page_Of_Text_Type is array (1..Number_Of_Lines) + of Line_Of_Text_Type; + + Text_Page : Page_Of_Text_Type := ("The platoon of Marines ", + "moved south on the south ", + "road to the airfield. "); + + TC_Revised_Line_1 : constant String := "The XXXXXXX of XXXXXXX "; + TC_Revised_Line_2 : constant String := "moved XXXXX on the XXXXX "; + TC_Revised_Line_3 : constant String := "XXXX to the XXXXXXXX. "; + + --- + + procedure Censor (Source_String : in out String; + Pattern_String : in String) is + + -- Create a replacement string that is the same length as the + -- pattern string being removed. + Replacement : constant String := -- "*" + Ada.Strings.Fixed."*"(Pattern_String'Length, 'X'); + + Going : Ada.Strings.Direction := Ada.Strings.Forward; + Map : constant Ada.Strings.Maps.Character_Mapping := + Ada.Strings.Maps.Identity; + Start_Pos, + Index : Natural := Source_String'First; + + + begin -- Censor + + -- Accumulate count of total replacement operations. + + TC_Total := TC_Total + -- Count + Ada.Strings.Fixed.Count (Source => Source_String, + Pattern => Pattern_String, + Mapping => Map); + loop + + Index := Ada.Strings.Fixed.Index -- Index + (Source_String(Start_Pos..Source_String'Last), + Pattern_String, + Going, + Map); + + exit when Index = 0; -- No matches, exit loop. + + -- if a match was found, modify the substring. + Ada.Strings.Fixed.Replace_Slice -- Replace_Slice + (Source_String, + Index, + Index + Pattern_String'Length - 1, + Replacement); + Start_Pos := Index + Pattern_String'Length; + + end loop; + + end Censor; + + + begin + + -- Invoke Censor subprogram to cleanse text. + -- Loop through each line of text, and check for the presence of each + -- restricted word. + -- Use the Trim function to eliminate leading or trailing blanks from + -- the restricted word parameters. + + for Line in 1..Number_Of_Lines loop + for Word in Restricted_Words'Range loop + Censor (Text_Page(Line), + Ada.Strings.Fixed.Trim(Restricted_Words(Word), -- Trim + Ada.Strings.Both)); + end loop; + end loop; + + + -- Validate results. + + if TC_Total /= 6 then + Report.Failed ("Incorrect number of substitutions performed"); + end if; + + if Text_Page(1) /= TC_Revised_Line_1 then + Report.Failed ("Incorrect substitutions on Line 1"); + end if; + + if Text_Page(2) /= TC_Revised_Line_2 then + Report.Failed ("Incorrect substitutions on Line 2"); + end if; + + if Text_Page(3) /= TC_Revised_Line_3 then + Report.Failed ("Incorrect substitutions on Line 3"); + end if; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + + Report.Result; + +end CXA4002; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4003.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4003.a new file mode 100644 index 000000000..cd57a9296 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4003.a @@ -0,0 +1,326 @@ +-- CXA4003.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 subprograms defined in package Ada.Strings.Fixed are +-- available, and that they produce correct results. Specifically, +-- check the subprograms Index, Index_Non_Blank, Head, Tail, Translate, +-- Find_Token, Move, Overwrite, and Replace_Slice. +-- +-- TEST DESCRIPTION: +-- This test demonstrates how certain fixed string operations could be +-- used in string information processing. A procedure is defined that +-- will extract portions of a 50 character string that correspond to +-- certain data items (i.e., name, address, state, zip code). These +-- parsed items will then be added to the appropriate fields of data +-- base elements. These data base elements are then compared for +-- accuracy against a similar set of predefined data base elements. +-- +-- A variety of fixed string processing subprograms are used in this +-- test. Each parsing operation uses a different combination +-- of the available subprograms to accomplish the same goal, therefore +-- continuity of approach to string parsing is not seen in this test. +-- However, a wide variety of possible approaches are demonstrated, while +-- exercising a large number of the total predefined subprograms of +-- package Ada.Strings.Fixed. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +with Ada.Strings.Fixed; +with Ada.Strings.Maps; +with Report; + +procedure CXA4003 is + +begin + + Report.Test ("CXA4003", "Check that the subprograms defined in package " & + "Ada.Strings.Fixed are available, and that they " & + "produce correct results"); + + Test_Block: + declare + + Number_Of_Info_Strings : constant Natural := 3; + DB_Size : constant Natural := Number_Of_Info_Strings; + Count : Natural := 0; + Finished_Processing : Boolean := False; + Blank_String : constant String := " "; + + subtype Info_String_Type is String (1..50); + type Info_String_Storage_Type is + array (1..Number_Of_Info_Strings) of Info_String_Type; + + + subtype Name_Type is String (1..10); + subtype Street_Number_Type is String (1..5); + subtype Street_Name_Type is String (1..10); + subtype City_Type is String (1..10); + subtype State_Type is String (1..2); + subtype Zip_Code_Type is String (1..5); + + type Data_Base_Element_Type is + record + Name : Name_Type := (others => ' '); + Street_Number : Street_Number_Type := (others => ' '); + Street_Name : Street_Name_Type := (others => ' '); + City : City_Type := (others => ' '); + State : State_Type := (others => ' '); + Zip_Code : Zip_Code_Type := (others => ' '); + end record; + + type Data_Base_Type is array (1..DB_Size) of Data_Base_Element_Type; + + Data_Base : Data_Base_Type; + + --- + + Info_String_1 : Info_String_Type := + "Joe_Jones 123 Sixth_St San_Diego CA 98765"; + + Info_String_2 : Info_String_Type := + "Sam_Smith 56789 S._Seventh Carlsbad CA 92177"; + + Info_String_3 : Info_String_Type := + "Jane_Brown 1219 Info_Lane Tuscon AZ 85643"; + + + Info_Strings : Info_String_Storage_Type := (1 => Info_String_1, + 2 => Info_String_2, + 3 => Info_String_3); + + + + TC_DB_Element_1 : Data_Base_Element_Type := + ("Joe Jones ", "123 ", "Sixth St ", "San Diego ", "CA", "98765"); + + TC_DB_Element_2 : Data_Base_Element_Type := + ("Sam Smith ", "56789", "S. Seventh", "Carlsbad ", "CA", "92177"); + + TC_DB_Element_3 : Data_Base_Element_Type := + ("Jane Brown", "1219 ", "Info Lane ", "Tuscon ", "AZ", "85643"); + + TC_Data_Base : Data_Base_Type := (TC_DB_Element_1, + TC_DB_Element_2, + TC_DB_Element_3); + + --- + + + procedure Store_Information + (Info_String : in Info_String_Type; + DB_Record : in out Data_Base_Element_Type) is + + package AS renames Ada.Strings; + use type AS.Maps.Character_Set; + + UnderScore : AS.Maps.Character_Sequence := "_"; + Blank : AS.Maps.Character_Sequence := " "; + + Start, + Stop : Natural := 0; + + Underscore_to_Blank_Map : constant AS.Maps.Character_Mapping := + AS.Maps.To_Mapping(From => UnderScore, + To => Blank); + + Numeric_Set : constant AS.Maps.Character_Set := + AS.Maps.To_Set("0123456789"); + + Cal : constant AS.Maps.Character_Sequence := "CA"; + California_Set : constant AS.Maps.Character_Set := + AS.Maps.To_Set(Cal); + Arizona_Set : constant AS.Maps.Character_Set := + AS.Maps.To_Set("AZ"); + Nevada_Set : constant AS.Maps.Character_Set := + AS.Maps.To_Set("NV"); + + begin + + -- Find the starting position of the name field (first non-blank), + -- then, from that position, find the end of the name field (first + -- blank). + + Start := AS.Fixed.Index_Non_Blank(Info_String); + Stop := AS.Fixed.Index (Info_String(Start..Info_String'Length), + AS.Maps.To_Set(' '), + AS.Inside, + AS.Forward) - 1 ; + + -- Store the name field in the data base element field for "Name". + + DB_Record.Name := AS.Fixed.Head(Info_String(1..Stop), + DB_Record.Name'Length); + + -- Replace any underscore characters in the name field + -- that were used to separate first/middle/last names. + + AS.Fixed.Translate (DB_Record.Name, Underscore_to_Blank_Map); + + + -- Continue the extraction process; now find the position of + -- the street number in the string. + + Start := Stop + 1; + + AS.Fixed.Find_Token(Info_String(Start..Info_String'Length), + Numeric_Set, + AS.Inside, + Start, + Stop); + + -- Store the street number field in the appropriate data base + -- element. + -- No modification of the default parameters of procedure Move + -- is required. + + AS.Fixed.Move(Source => Info_String(Start..Stop), + Target => DB_Record.Street_Number); + + + -- Continue the extraction process; find the street name in the + -- info string. Skip blanks to the start of the street name, then + -- search for the index of the next blank character in the string. + + Start := + AS.Fixed.Index_Non_Blank(Info_String(Stop+1..Info_String'Length)); + + Stop := + AS.Fixed.Index(Info_String(Start..Info_String'Length), + Blank_String) - 1; + + -- Store the street name in the appropriate data base element field. + + AS.Fixed.Overwrite(DB_Record.Street_Name, + 1, + Info_String(Start..Stop)); + + -- Replace any underscore characters in the street name field + -- that were used as word separation. + + DB_Record.Street_Name := AS.Fixed.Translate(DB_Record.Street_Name, + Underscore_to_Blank_Map); + + + -- Continue the extraction; remove the city name from the string. + + Start := + AS.Fixed.Index_Non_Blank(Info_String(Stop+1..Info_String'Length)); + + Stop := + AS.Fixed.Index(Info_String(Start..Info_String'Length), + Blank_String) - 1; + + -- Store the city name field in the appropriate data base element. + + AS.Fixed.Replace_Slice(DB_Record.City, + 1, + DB_Record.City'Length, + Info_String(Start..Stop)); + + -- Replace any underscore characters in the city name field + -- that were used as word separation. + + AS.Fixed.Translate (DB_Record.City, Underscore_to_Blank_Map); + + + -- Continue the extraction; remove the state identifier from the + -- info string. + + Start := Stop + 1; + + AS.Fixed.Find_Token(Info_String(Start..Info_String'Length), + AS.Maps."OR"(California_Set, + AS.Maps."OR"(Nevada_Set, Arizona_Set)), + AS.Inside, + Start, + Stop); + + -- Store the state indicator into the data base element. + + AS.Fixed.Move(Source => Info_String(Start..Stop), + Target => DB_Record.State, + Drop => Ada.Strings.Right, + Justify => Ada.Strings.Left, + Pad => AS.Space); + + + -- Continue the extraction process; remove the final data item in + -- the info string, the zip code, and place it into the + -- corresponding data base element. + + DB_Record.Zip_Code := AS.Fixed.Tail(Info_String, + DB_Record.Zip_Code'Length); + + exception + when AS.Length_Error => + Report.Failed ("Length_Error raised in procedure"); + when AS.Pattern_Error => + Report.Failed ("Pattern_Error raised in procedure"); + when AS.Translation_Error => + Report.Failed ("Translation_Error raised in procedure"); + when others => + Report.Failed ("Exception raised in procedure"); + end Store_Information; + + + begin + + -- Loop thru the information strings, extract the name and address + -- information, place this info into elements of the data base. + + while not Finished_Processing loop + + Count := Count + 1; + + Store_Information (Info_Strings(Count), Data_Base(Count)); + + Finished_Processing := (Count = Number_Of_Info_Strings); + + end loop; + + + -- Verify that the string processing was successful. + + for i in 1..DB_Size loop + if Data_Base(i) /= TC_Data_Base(i) then + Report.Failed + ("Data processing error on record " & Integer'Image(i)); + end if; + end loop; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + + Report.Result; + +end CXA4003; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4004.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4004.a new file mode 100644 index 000000000..ec11f7d50 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4004.a @@ -0,0 +1,431 @@ +-- CXA4004.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 subprograms defined in package Ada.Strings.Fixed are +-- available, and that they produce correct results. Specifically, check +-- the subprograms Count, Find_Token, Index, Index_Non_Blank, and Move. +-- +-- TEST DESCRIPTION: +-- This test, when combined with tests CXA4002,3, and 5 will provide +-- thorough coverage of the functionality found in Ada.Strings.Fixed. +-- This test contains many small, specific test cases, situations that +-- although common in user environments, are often difficult to generate +-- in large numbers in a application-based test. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 10 Apr 95 SAIC Corrected subtest for Move, Drop=Right. +-- +--! + +with Report; +with Ada.Strings; +with Ada.Strings.Fixed; +with Ada.Strings.Maps; + +procedure CXA4004 is +begin + + Report.Test("CXA4004", "Check that the subprograms defined in " & + "package Ada.Strings.Fixed are available, " & + "and that they produce correct results"); + + Test_Block: + declare + + package ASF renames Ada.Strings.Fixed; + package Maps renames Ada.Strings.Maps; + + Result_String : String(1..10) := (others => Ada.Strings.Space); + + Source_String1 : String(1..5) := "abcde"; -- odd length string + Source_String2 : String(1..6) := "abcdef"; -- even length string + Source_String3 : String(1..12) := "abcdefghijkl"; + Source_String4 : String(1..12) := "abcdefghij "; -- last two ch pad + Source_String5 : String(1..12) := " cdefghijkl"; -- first two ch pad + Source_String6 : String(1..12) := "abcdefabcdef"; + + Location : Natural := 0; + Slice_Start : Positive; + Slice_End, + Slice_Count : Natural := 0; + + CD_Set : Maps.Character_Set := Maps.To_Set("cd"); + ABCD_Set : Maps.Character_Set := Maps.To_Set("abcd"); + A_to_F_Set : Maps.Character_Set := Maps.To_Set("abcdef"); + + CD_to_XY_Map : Maps.Character_Mapping := + Maps.To_Mapping(From => "cd", To => "xy"); + + begin + + -- Procedure Move + + -- Evaluate the Procedure Move with various combinations of + -- parameters. + + -- Justify = Left (default case) + + ASF.Move(Source => Source_String1, -- "abcde" + Target => Result_String); + + if Result_String /= "abcde " then + Report.Failed("Incorrect result from Move with Justify = Left"); + end if; + + -- Justify = Right + + ASF.Move(Source => Source_String2, -- "abcdef" + Target => Result_String, + Drop => Ada.Strings.Error, + Justify => Ada.Strings.Right); + + if Result_String /= " abcdef" then + Report.Failed("Incorrect result from Move with Justify = Right"); + end if; + + -- Justify = Center (two cases, odd and even pad lengths) + + ASF.Move(Source_String1, -- "abcde" + Result_String, + Ada.Strings.Error, + Ada.Strings.Center, + 'x'); -- non-default padding. + + if Result_String /= "xxabcdexxx" then -- Unequal padding added right + Report.Failed("Incorrect result from Move with Justify = Center-1"); + end if; + + ASF.Move(Source_String2, -- "abcdef" + Result_String, + Ada.Strings.Error, + Ada.Strings.Center); + + if Result_String /= " abcdef " then -- Equal padding added on L/R. + Report.Failed("Incorrect result from Move with Justify = Center-2"); + end if; + + -- When the source string is longer than the target string, several + -- cases can be examined, with the results depending on the value of + -- the Drop parameter. + + -- Drop = Left + + ASF.Move(Source => Source_String3, -- "abcdefghijkl" + Target => Result_String, + Drop => Ada.Strings.Left); + + if Result_String /= "cdefghijkl" then + Report.Failed("Incorrect result from Move with Drop = Left"); + end if; + + -- Drop = Right + + ASF.Move(Source_String3, Result_String, Ada.Strings.Right); + + if Result_String /= "abcdefghij" then + Report.Failed("Incorrect result from Move with Drop = Right"); + end if; + + -- Drop = Error + -- The effect in this case depends on the value of the justify + -- parameter, and on whether any characters in Source other than + -- Pad would fail to be copied. + + -- Drop = Error, Justify = Left, right overflow characters are pad. + + ASF.Move(Source => Source_String4, -- "abcdefghij " + Target => Result_String, + Drop => Ada.Strings.Error, + Justify => Ada.Strings.Left); + + if not(Result_String = "abcdefghij") then -- leftmost 10 characters + Report.Failed("Incorrect result from Move with Drop = Error - 1"); + end if; + + -- Drop = Error, Justify = Right, left overflow characters are pad. + + ASF.Move(Source_String5, -- " cdefghijkl" + Result_String, + Ada.Strings.Error, + Ada.Strings.Right); + + if Result_String /= "cdefghijkl" then -- rightmost 10 characters + Report.Failed("Incorrect result from Move with Drop = Error - 2"); + end if; + + -- In other cases of Drop=Error, Length_Error is propagated, such as: + + begin + + ASF.Move(Source_String3, -- 12 characters, no Pad. + Result_String, -- 10 characters + Ada.Strings.Error, + Ada.Strings.Left); + + Report.Failed("Length_Error not raised by Move - 1"); + + exception + when Ada.Strings.Length_Error => null; -- OK + when others => + Report.Failed("Incorrect exception raised by Move - 1"); + end; + + + + -- Function Index + -- (Other usage examples of this function found in CXA4002-3.) + -- Check when the pattern is not found in the source. + + if ASF.Index("abcdef", "gh") /= 0 or + ASF.Index("abcde", "abcdef") /= 0 or -- pattern > source + ASF.Index("xyz", + "abcde", + Ada.Strings.Backward) /= 0 or + ASF.Index("", "ab") /= 0 or -- null source string. + ASF.Index("abcde", " ") /= 0 -- blank pattern. + then + Report.Failed("Incorrect result from Index, no pattern match"); + end if; + + -- Check that Pattern_Error is raised when the pattern is the + -- null string. + begin + Location := ASF.Index(Source_String6, -- "abcdefabcdef" + "", -- null pattern string. + Ada.Strings.Forward); + Report.Failed("Pattern_Error not raised by Index"); + exception + when Ada.Strings.Pattern_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by Index, null pattern"); + end; + + -- Use the search direction "backward" to locate the particular + -- pattern within the source string. + + Location := ASF.Index(Source_String6, -- "abcdefabcdef" + "de", -- slice 4..5, 10..11 + Ada.Strings.Backward); -- search from right end. + + if Location /= 10 then + Report.Failed("Incorrect result from Index going Backward"); + end if; + + -- Using the version of Index testing character set membership, + -- check combinations of forward/backward, inside/outside parameter + -- configurations. + + if ASF.Index(Source => Source_String1, -- "abcde" + Set => CD_Set, + Test => Ada.Strings.Inside, + Going => Ada.Strings.Forward) /= 3 or -- 'c' at pos 3. + ASF.Index(Source_String6, -- "abcdefabcdef" + CD_Set, + Ada.Strings.Outside, + Ada.Strings.Backward) /= 12 or -- 'f' at position 12 + ASF.Index(Source_String6, -- "abcdefabcdef" + CD_Set, + Ada.Strings.Inside, + Ada.Strings.Backward) /= 10 or -- 'd' at position 10 + ASF.Index("cdcdcdcdacdcdcdcd", + CD_Set, + Ada.Strings.Outside, + Ada.Strings.Forward) /= 9 -- 'a' at position 9 + then + Report.Failed("Incorrect result from function Index for sets - 1"); + end if; + + -- Additional interesting uses/combinations using Index for sets. + + if ASF.Index("cd", -- same size, str-set + CD_Set, + Ada.Strings.Inside, + Ada.Strings.Forward) /= 1 or -- 'c' at position 1 + ASF.Index("abcd", -- same size, str-set, + Maps.To_Set("efgh"), -- different contents. + Ada.Strings.Outside, + Ada.Strings.Forward) /= 1 or + ASF.Index("abccd", -- set > string + Maps.To_Set("acegik"), + Ada.Strings.Inside, + Ada.Strings.Backward) /= 4 or -- 'c' at position 4 + ASF.Index("abcde", + Maps.Null_Set) /= 0 or + ASF.Index("", -- Null string. + CD_Set) /= 0 or + ASF.Index("abc ab", -- blank included + Maps.To_Set("e "), -- in string and set. + Ada.Strings.Inside, + Ada.Strings.Backward) /= 4 -- blank in string. + then + Report.Failed("Incorrect result from function Index for sets - 2"); + end if; + + + + -- Function Index_Non_Blank. + -- (Other usage examples of this function found in CXA4002-3.) + + + if ASF.Index_Non_Blank(Source => Source_String4, -- "abcdefghij " + Going => Ada.Strings.Backward) /= 10 or + ASF.Index_Non_Blank("abc def ghi jkl ", + Ada.Strings.Backward) /= 15 or + ASF.Index_Non_Blank(" abcdef") /= 3 or + ASF.Index_Non_Blank(" ") /= 0 + then + Report.Failed("Incorrect result from Index_Non_Blank"); + end if; + + + + -- Function Count + -- (Other usage examples of this function found in CXA4002-3.) + + if ASF.Count("abababa", "aba") /= 2 or + ASF.Count("abababa", "ab" ) /= 3 or + ASF.Count("babababa", "ab") /= 3 or + ASF.Count("abaabaaba", "aba") /= 3 or + ASF.Count("xxxxxxxxxxxxxxxxxxxy", "xy") /= 1 or + ASF.Count("xxxxxxxxxxxxxxxxxxxx", "x") /= 20 + then + Report.Failed("Incorrect result from Function Count"); + end if; + + -- Determine the number of slices of Source that when mapped to a + -- non-identity map, match the pattern string. + + Slice_Count := ASF.Count(Source_String6, -- "abcdefabcdef" + "xy", + CD_to_XY_Map); -- maps 'c' to 'x', 'd' to 'y' + + if Slice_Count /= 2 then -- two slices "xy" in "mapped" Source_String6 + Report.Failed("Incorrect result from Count with non-identity map"); + end if; + + -- If the pattern supplied to Function Count is the null string, then + -- Pattern_Error is propagated. + + declare + The_Null_String : constant String := ""; + begin + Slice_Count := ASF.Count(Source_String6, The_Null_String); + Report.Failed("Pattern_Error not raised by Function Count"); + exception + when Ada.Strings.Pattern_Error => null; -- OK + when others => + Report.Failed("Incorrect exception from Count with null pattern"); + end; + + + -- Function Count returning the number of characters in a particular + -- set that are found in source string. + + if ASF.Count(Source_String6, CD_Set) /= 4 then -- 2 'c' and 'd' chars. + Report.Failed("Incorrect result from Count with set"); + end if; + + + + -- Function Find_Token. + -- (Other usage examples of this function found in CXA4002-3.) + + ASF.Find_Token(Source => Source_String6, -- First slice with no + Set => ABCD_Set, -- 'a', 'b', 'c', or 'd' + Test => Ada.Strings.Outside, -- is "ef" at 5..6. + First => Slice_Start, + Last => Slice_End); + + if Slice_Start /= 5 or Slice_End /= 6 then + Report.Failed("Incorrect result from Find_Token - 1"); + end if; + + -- If no appropriate slice is contained by the source string, then the + -- value returned in Last is zero, and the value in First is + -- Source'First. + + ASF.Find_Token(Source_String6, -- "abcdefabcdef" + A_to_F_Set, -- Set of characters 'a' thru 'f'. + Ada.Strings.Outside, -- No characters outside this set. + Slice_Start, + Slice_End); + + if Slice_Start /= Source_String6'First or Slice_End /= 0 then + Report.Failed("Incorrect result from Find_Token - 2"); + end if; + + -- Additional testing of Find_Token. + + ASF.Find_Token("eabcdabcddcab", + ABCD_Set, + Ada.Strings.Inside, + Slice_Start, + Slice_End); + + if Slice_Start /= 2 or Slice_End /= 13 then + Report.Failed("Incorrect result from Find_Token - 3"); + end if; + + ASF.Find_Token("efghijklabcdabcd", + ABCD_Set, + Ada.Strings.Outside, + Slice_Start, + Slice_End); + + if Slice_Start /= 1 or Slice_End /= 8 then + Report.Failed("Incorrect result from Find_Token - 4"); + end if; + + ASF.Find_Token("abcdefgabcdabcd", + ABCD_Set, + Ada.Strings.Outside, + Slice_Start, + Slice_End); + + if Slice_Start /= 5 or Slice_End /= 7 then + Report.Failed("Incorrect result from Find_Token - 5"); + end if; + + ASF.Find_Token("abcdcbabcdcba", + ABCD_Set, + Ada.Strings.Inside, + Slice_Start, + Slice_End); + + if Slice_Start /= 1 or Slice_End /= 13 then + Report.Failed("Incorrect result from Find_Token - 6"); + end if; + + + exception + when others => Report.Failed("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + +end CXA4004; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4005.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4005.a new file mode 100644 index 000000000..d61f853ca --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4005.a @@ -0,0 +1,683 @@ +-- CXA4005.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 subprograms defined in package Ada.Strings.Fixed are +-- available, and that they produce correct results. Specifically, +-- check the subprograms Delete, Head, Insert, Overwrite, Replace_Slice, +-- Tail, Trim, and "*". +-- +-- TEST DESCRIPTION: +-- This test, when combined with tests CXA4002-4 will provide coverage +-- of the functionality found in Ada.Strings.Fixed. +-- This test contains many small, specific test cases, situations that +-- although common in user environments, are often difficult to generate +-- in large numbers in a application-based test. They represent +-- individual usage paradigms in-the-small. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 11 Apr 95 SAIC Corrected acceptance conditions of certain +-- subtests. +-- 06 Nov 95 SAIC Fixed bugs for ACVC 2.0.1. +-- 22 Feb 01 PHL Check that the lower bound of the result is 1. +-- 13 Mar 01 RLB Fixed a couple of ACATS style violations; +-- removed pointless checks of procedures. +-- Added checks of other functions. These changes +-- were made to test Defect Report 8652/0049, as +-- reflected in Technical Corrigendum 1. +-- +--! + +with Report; +with Ada.Strings; +with Ada.Strings.Fixed; +with Ada.Strings.Maps; + +procedure CXA4005 is + + type TC_Name_Holder is access String; + Name : TC_Name_Holder; + + function TC_Check (S : String) return String is + begin + if S'First /= 1 then + Report.Failed ("Lower bound of result of function " & Name.all & + " is" & Integer'Image (S'First)); + end if; + return S; + end TC_Check; + + procedure TC_Set_Name (N : String) is + begin + Name := new String'(N); + end TC_Set_Name; + +begin + + Report.Test("CXA4005", "Check that the subprograms defined in " & + "package Ada.Strings.Fixed are available, " & + "and that they produce correct results"); + + Test_Block: + declare + + package ASF renames Ada.Strings.Fixed; + package Maps renames Ada.Strings.Maps; + + Result_String, + Delete_String, + Insert_String, + Trim_String, + Overwrite_String : String(1..10) := (others => Ada.Strings.Space); + + Source_String1 : String(1..5) := "abcde"; -- odd length string + Source_String2 : String(1..6) := "abcdef"; -- even length string + Source_String3 : String(1..12) := "abcdefghijkl"; + Source_String4 : String(1..12) := "abcdefghij "; -- last two ch pad + Source_String5 : String(1..12) := " cdefghijkl"; -- first two ch pad + Source_String6 : String(1..12) := "abcdefabcdef"; + + Location : Natural := 0; + Slice_Start : Positive; + Slice_End, + Slice_Count : Natural := 0; + + CD_Set : Maps.Character_Set := Maps.To_Set("cd"); + X_Set : Maps.Character_Set := Maps.To_Set('x'); + ABCD_Set : Maps.Character_Set := Maps.To_Set("abcd"); + A_to_F_Set : Maps.Character_Set := Maps.To_Set("abcdef"); + + CD_to_XY_Map : Maps.Character_Mapping := + Maps.To_Mapping(From => "cd", To => "xy"); + + begin + + -- Procedure Replace_Slice + -- The functionality of this procedure + -- is similar to procedure Move, and + -- is tested here in the same manner, evaluated + -- with various combinations of parameters. + + -- Index_Error propagation when Low > Source'Last + 1 + + begin + ASF.Replace_Slice(Result_String, + Result_String'Last + 2, -- should raise exception + Result_String'Last, + "xxxxxxx"); + Report.Failed("Index_Error not raised by Replace_Slice - 1"); + exception + when Ada.Strings.Index_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception from Replace_Slice - 1"); + end; + + -- Index_Error propagation when High < Source'First - 1 + + begin + ASF.Replace_Slice(Result_String(5..10), + 5, + 3, -- should raise exception since < 'First - 1. + "xxxxxxx"); + Report.Failed("Index_Error not raised by Replace_Slice - 2"); + exception + when Ada.Strings.Index_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception from Replace_Slice - 2"); + end; + + -- Justify = Left (default case) + + Result_String := "XXXXXXXXXX"; + + ASF.Replace_Slice(Source => Result_String, + Low => 1, + High => 10, + By => Source_String1); -- "abcde" + + if Result_String /= "abcde " then + Report.Failed("Incorrect result from Replace_Slice - Justify = Left"); + end if; + + -- Justify = Right + + ASF.Replace_Slice(Source => Result_String, + Low => 1, + High => Result_String'Last, + By => Source_String2, -- "abcdef" + Drop => Ada.Strings.Error, + Justify => Ada.Strings.Right); + + if Result_String /= " abcdef" then + Report.Failed("Incorrect result from Replace_Slice - Justify=Right"); + end if; + + -- Justify = Center (two cases, odd and even pad lengths) + + ASF.Replace_Slice(Result_String, + 1, + Result_String'Last, + Source_String1, -- "abcde" + Ada.Strings.Error, + Ada.Strings.Center, + 'x'); -- non-default padding. + + if Result_String /= "xxabcdexxx" then -- Unequal padding added right + Report.Failed("Incorrect result, Replace_Slice - Justify=Center - 1"); + end if; + + ASF.Replace_Slice(Result_String, + 1, + Result_String'Last, + Source_String2, -- "abcdef" + Ada.Strings.Error, + Ada.Strings.Center); + + if Result_String /= " abcdef " then -- Equal padding added on L/R. + Report.Failed("Incorrect result from Replace_Slice with " & + "Justify = Center - 2"); + end if; + + -- When the source string is longer than the target string, several + -- cases can be examined, with the results depending on the value of + -- the Drop parameter. + + -- Drop = Left + + ASF.Replace_Slice(Result_String, + 1, + Result_String'Last, + Source_String3, -- "abcdefghijkl" + Drop => Ada.Strings.Left); + + if Result_String /= "cdefghijkl" then + Report.Failed("Incorrect result from Replace_Slice - Drop=Left"); + end if; + + -- Drop = Right + + ASF.Replace_Slice(Result_String, + 1, + Result_String'Last, + Source_String3, -- "abcdefghijkl" + Ada.Strings.Right); + + if Result_String /= "abcdefghij" then + Report.Failed("Incorrect result, Replace_Slice with Drop=Right"); + end if; + + -- Drop = Error + + -- The effect in this case depends on the value of the justify + -- parameter, and on whether any characters in Source other than + -- Pad would fail to be copied. + + -- Drop = Error, Justify = Left, right overflow characters are pad. + + ASF.Replace_Slice(Result_String, + 1, + Result_String'Last, + Source_String4, -- "abcdefghij " + Drop => Ada.Strings.Error, + Justify => Ada.Strings.Left); + + if not(Result_String = "abcdefghij") then -- leftmost 10 characters + Report.Failed("Incorrect result, Replace_Slice - Drop = Error - 1"); + end if; + + -- Drop = Error, Justify = Right, left overflow characters are pad. + + ASF.Replace_Slice(Source => Result_String, + Low => 1, + High => Result_String'Last, + By => Source_String5, -- " cdefghijkl" + Drop => Ada.Strings.Error, + Justify => Ada.Strings.Right); + + if Result_String /= "cdefghijkl" then -- rightmost 10 characters + Report.Failed("Incorrect result, Replace_Slice - Drop = Error - 2"); + end if; + + -- In other cases of Drop=Error, Length_Error is propagated, such as: + + begin + + ASF.Replace_Slice(Source => Result_String, + Low => 1, + High => Result_String'Last, + By => Source_String3, -- "abcdefghijkl" + Drop => Ada.Strings.Error); + + Report.Failed("Length_Error not raised by Replace_Slice - 1"); + + exception + when Ada.Strings.Length_Error => null; -- OK + when others => + Report.Failed("Incorrect exception from Replace_Slice - 3"); + end; + + + -- Function Replace_Slice + + TC_Set_Name ("Replace_Slice"); + + if TC_Check (ASF.Replace_Slice("abcde", 3, 3, "x")) + /= "abxde" or -- High = Low + TC_Check (ASF.Replace_Slice("abc", 2, 3, "xyz")) /= "axyz" or + TC_Check (ASF.Replace_Slice("abcd", 4, 1, "xy")) + /= "abcxyd" or -- High < Low + TC_Check (ASF.Replace_Slice("abc", 2, 3, "x")) /= "ax" or + TC_Check (ASF.Replace_Slice("a", 1, 1, "z")) /= "z" + then + Report.Failed("Incorrect result from Function Replace_Slice - 1"); + end if; + + if TC_Check (ASF.Replace_Slice("abcde", 5, 5, "z")) + /= "abcdz" or -- By length 1 + TC_Check (ASF.Replace_Slice("abc", 1, 3, "xyz")) + /= "xyz" or -- High > Low + TC_Check (ASF.Replace_Slice("abc", 3, 2, "xy")) + /= "abxyc" or -- insert + TC_Check (ASF.Replace_Slice("a", 1, 1, "xyz")) /= "xyz" + then + Report.Failed("Incorrect result from Function Replace_Slice - 2"); + end if; + + + + -- Function Insert. + + TC_Set_Name ("Insert"); + + declare + New_String : constant String := + TC_Check ( + ASF.Insert(Source => Source_String1(2..5), -- "bcde" + Before => 3, + New_Item => Source_String2)); -- "abcdef" + begin + if New_String /= "babcdefcde" then + Report.Failed("Incorrect result from Function Insert - 1"); + end if; + end; + + if TC_Check (ASF.Insert("a", 1, "z")) /= "za" or + TC_Check (ASF.Insert("abc", 3, "")) /= "abc" or + TC_Check (ASF.Insert("abc", 1, "z")) /= "zabc" + then + Report.Failed("Incorrect result from Function Insert - 2"); + end if; + + begin + if TC_Check (ASF.Insert(Source => Source_String1(2..5), -- "bcde" + Before => Report.Ident_Int(7), + New_Item => Source_String2)) -- "abcdef" + /= "babcdefcde" then + Report.Failed("Index_Error not raised by Insert - 3A"); + else + Report.Failed("Index_Error not raised by Insert - 3B"); + end if; + exception + when Ada.Strings.Index_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception from Insert - 3"); + end; + + + -- Procedure Insert + + -- Drop = Right + + ASF.Insert(Source => Insert_String, + Before => 6, + New_Item => Source_String2, -- "abcdef" + Drop => Ada.Strings.Right); + + if Insert_String /= " abcde" then -- last char of New_Item dropped. + Report.Failed("Incorrect result from Insert with Drop = Right"); + end if; + + -- Drop = Left + + ASF.Insert(Source => Insert_String, -- 10 char string + Before => 2, -- 9 chars, 2..10 available + New_Item => Source_String3, -- 12 characters long. + Drop => Ada.Strings.Left); -- truncate from Left. + + if Insert_String /= "l abcde" then -- 10 chars, leading blank. + Report.Failed("Incorrect result from Insert with Drop=Left"); + end if; + + -- Drop = Error + + begin + ASF.Insert(Source => Result_String, -- 10 chars + Before => Result_String'Last, + New_Item => "abcdefghijk", + Drop => Ada.Strings.Error); + Report.Failed("Exception not raised by Procedure Insert"); + exception + when Ada.Strings.Length_Error => null; -- OK, expected exception + when others => + Report.Failed("Incorrect exception raised by Procedure Insert"); + end; + + + + -- Function Overwrite + + TC_Set_Name ("Overwrite"); + + Overwrite_String := TC_Check ( + ASF.Overwrite(Result_String, -- 10 chars + 1, -- starting at pos=1 + Source_String3(1..10))); + + if Overwrite_String /= Source_String3(1..10) then + Report.Failed("Incorrect result from Function Overwrite - 1"); + end if; + + + if TC_Check (ASF.Overwrite("abcdef", 4, "xyz")) /= "abcxyz" or + TC_Check (ASF.Overwrite("a", 1, "xyz")) + /= "xyz" or -- chars appended + TC_Check (ASF.Overwrite("abc", 3, " ")) + /= "ab " or -- blanks appended + TC_Check (ASF.Overwrite("abcde", 1, "z" )) /= "zbcde" + then + Report.Failed("Incorrect result from Function Overwrite - 2"); + end if; + + + + -- Procedure Overwrite, with truncation. + + ASF.Overwrite(Source => Overwrite_String, -- 10 characters. + Position => 1, + New_Item => Source_String3, -- 12 characters. + Drop => Ada.Strings.Left); + + if Overwrite_String /= "cdefghijkl" then + Report.Failed("Incorrect result from Overwrite with Drop=Left"); + end if; + + -- The default drop value is Right, used here. + + ASF.Overwrite(Source => Overwrite_String, -- 10 characters. + Position => 1, + New_Item => Source_String3); -- 12 characters. + + if Overwrite_String /= "abcdefghij" then + Report.Failed("Incorrect result from Overwrite with Drop=Right"); + end if; + + -- Drop = Error + + begin + ASF.Overwrite(Source => Overwrite_String, -- 10 characters. + Position => 1, + New_Item => Source_String3, -- 12 characters. + Drop => Ada.Strings.Error); + Report.Failed("Exception not raised by Procedure Overwrite"); + exception + when Ada.Strings.Length_Error => null; -- OK, expected exception. + when others => + Report.Failed + ("Incorrect exception raised by Procedure Overwrite"); + end; + + Overwrite_String := "ababababab"; + ASF.Overwrite(Overwrite_String, Overwrite_String'Last, "z"); + ASF.Overwrite(Overwrite_String, Overwrite_String'First,"z"); + ASF.Overwrite(Overwrite_String, 5, "zz"); + + if Overwrite_String /= "zbabzzabaz" then + Report.Failed("Incorrect result from Procedure Overwrite"); + end if; + + + + -- Function Delete + + TC_Set_Name ("Delete"); + + declare + New_String1 : constant String := -- This returns a 4 char string. + TC_Check (ASF.Delete(Source => Source_String3, + From => 3, + Through => 10)); + New_String2 : constant String := -- This returns Source. + TC_Check (ASF.Delete(Source_String3, 10, 3)); + begin + if New_String1 /= "abkl" or + New_String2 /= Source_String3 + then + Report.Failed("Incorrect result from Function Delete - 1"); + end if; + end; + + if TC_Check (ASF.Delete("a", 1, 1)) + /= "" or -- Source length = 1 + TC_Check (ASF.Delete("abc", 1, 2)) + /= "c" or -- From = Source'First + TC_Check (ASF.Delete("abc", 3, 3)) + /= "ab" or -- From = Source'Last + TC_Check (ASF.Delete("abc", 3, 1)) + /= "abc" -- From > Through + then + Report.Failed("Incorrect result from Function Delete - 2"); + end if; + + + + -- Procedure Delete + + -- Justify = Left + + Delete_String := Source_String3(1..10); -- Initialize to "abcdefghij" + + ASF.Delete(Source => Delete_String, + From => 6, + Through => Delete_String'Last, + Justify => Ada.Strings.Left, + Pad => 'x'); -- pad with char 'x' + + if Delete_String /= "abcdexxxxx" then + Report.Failed("Incorrect result from Delete - Justify = Left"); + end if; + + -- Justify = Right + + ASF.Delete(Source => Delete_String, -- Remove x"s from end and + From => 6, -- shift right. + Through => Delete_String'Last, + Justify => Ada.Strings.Right, + Pad => 'x'); -- pad with char 'x' on left. + + if Delete_String /= "xxxxxabcde" then + Report.Failed("Incorrect result from Delete - Justify = Right"); + end if; + + -- Justify = Center + + ASF.Delete(Source => Delete_String, + From => 1, + Through => 5, + Justify => Ada.Strings.Center, + Pad => 'z'); + + if Delete_String /= "zzabcdezzz" then -- extra pad char on right side. + Report.Failed("Incorrect result from Delete - Justify = Center"); + end if; + + + + -- Function Trim + -- Use non-identity character sets to perform the trim operation. + + TC_Set_Name ("Trim"); + + Trim_String := "cdabcdefcd"; + + -- Remove the "cd" from each end of the string. This will not effect + -- the "cd" slice at 5..6. + + declare + New_String : constant String := + TC_Check (ASF.Trim(Source => Trim_String, + Left => CD_Set, Right => CD_Set)); + begin + if New_String /= Source_String2 then -- string "abcdef" + Report.Failed("Incorrect result from Trim with character sets"); + end if; + end; + + if TC_Check (ASF.Trim("abcdef", Maps.Null_Set, Maps.Null_Set)) + /= "abcdef" then + Report.Failed("Incorrect result from Trim with Null sets"); + end if; + + if TC_Check (ASF.Trim("cdxx", CD_Set, X_Set)) /= "" then + Report.Failed("Incorrect result from Trim, string removal"); + end if; + + + -- Procedure Trim + + -- Justify = Right + + ASF.Trim(Source => Trim_String, + Left => CD_Set, + Right => CD_Set, + Justify => Ada.Strings.Right, + Pad => 'x'); + + if Trim_String /= "xxxxabcdef" then + Report.Failed("Incorrect result from Trim with Justify = Right"); + end if; + + -- Justify = Left + + ASF.Trim(Source => Trim_String, + Left => X_Set, + Right => Maps.Null_Set, + Justify => Ada.Strings.Left, + Pad => Ada.Strings.Space); + + if Trim_String /= "abcdef " then -- Padded with 4 blanks on right. + Report.Failed("Incorrect result from Trim with Justify = Left"); + end if; + + -- Justify = Center + + ASF.Trim(Source => Trim_String, + Left => ABCD_Set, + Right => CD_Set, + Justify => Ada.Strings.Center, + Pad => 'x'); + + if Trim_String /= "xxef xx" then -- Padded with 2 pad chars on L/R + Report.Failed("Incorrect result from Trim with Justify = Center"); + end if; + + + + -- Function Head, demonstrating use of padding. + + TC_Set_Name ("Head"); + + -- Use the characters of Source_String1 ("abcde") and pad the + -- last five characters of Result_String with 'x' characters. + + + Result_String := TC_CHeck (ASF.Head(Source_String1, 10, 'x')); + + if Result_String /= "abcdexxxxx" then + Report.Failed("Incorrect result from Function Head with padding"); + end if; + + if TC_Check (ASF.Head(" ab ", 2)) /= " " or + TC_Check (ASF.Head("a", 6, 'A')) /= "aAAAAA" or + TC_Check (ASF.Head("abcdefgh", 3, 'x')) /= "abc" or + TC_Check (ASF.Head(ASF.Head("abc ", 7, 'x'), 10, 'X')) + /= "abc xxXXX" + then + Report.Failed("Incorrect result from Function Head"); + end if; + + + + -- Function Tail, demonstrating use of padding. + + TC_Set_Name ("Tail"); + + -- Use the characters of Source_String1 ("abcde") and pad the + -- first five characters of Result_String with 'x' characters. + + Result_String := TC_Check (ASF.Tail(Source_String1, 10, 'x')); + + if Result_String /= "xxxxxabcde" then + Report.Failed("Incorrect result from Function Tail with padding"); + end if; + + if TC_Check (ASF.Tail("abcde ", 5)) + /= "cde " or -- blanks, back + TC_Check (ASF.Tail(" abc ", 8, ' ')) + /= " abc " or -- blanks, front/back + TC_Check (ASF.Tail("", 5, 'Z')) + /= "ZZZZZ" or -- pad characters only + TC_Check (ASF.Tail("abc", 0)) + /= "" or -- null result + TC_Check (ASF.Tail("abcdefgh", 3)) + /= "fgh" or + TC_Check (ASF.Tail(ASF.Tail(" abc ", 6, 'x'), + 10, + 'X')) /= "XXXXx abc " + then + Report.Failed("Incorrect result from Function Tail"); + end if; + + + -- Function "*" - with (Natural, String) parameters + + TC_Set_Name ("""*"""); + + if TC_Check (ASF."*"(3, Source_String1)) /= "abcdeabcdeabcde" or + TC_Check (ASF."*"(2, Source_String2)) /= Source_String6 or + TC_Check (ASF."*"(4, Source_String1(1..2))) /= "abababab" or + TC_Check (ASF."*"(0, Source_String1)) /= "" + then + Report.Failed("Incorrect result from Function ""*"" with strings"); + end if; + + exception + when others => Report.Failed("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + +end CXA4005; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4006.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4006.a new file mode 100644 index 000000000..e1d7f46f5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4006.a @@ -0,0 +1,319 @@ +-- CXA4006.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 subprograms defined in package Ada.Strings.Bounded are +-- available, and that they produce correct results. Specifically, check +-- the subprograms Length, Slice, "&", To_Bounded_String, Append, Index, +-- To_String, Replace_Slice, Trim, Overwrite, Delete, Insert, and +-- Translate. +-- +-- TEST DESCRIPTION: +-- This test demonstrates the uses of a variety of the string functions +-- found in the package Ada.Strings.Bounded, simulating the operations +-- found in a text processing package. +-- With bounded strings, the length of each "line" of text can vary up +-- to the instantiated maximum, allowing one to view a page of text as +-- a series of expandable lines. This provides flexibility in text +-- formatting of individual lines (strings). +-- Several subprograms are defined, all of which attempt to take advantage +-- of as many different bounded string utilities as possible. Often, +-- an operation that is being performed in a subprogram using a certain +-- bounded string utility could more efficiently be performed using a +-- a different utility. However, in the interest of including as broad +-- coverage as possible, a mixture of utilities is invoked in this test. +-- A simulated page of text is provided as a parameter to the test +-- defined subprograms, and the appropriate processing performed. The +-- processed page of text is then compared to a predefined "finished" +-- page, and test passage/failure is based on the results of this +-- comparison. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +with Ada.Strings; +with Ada.Strings.Bounded; +with Ada.Strings.Maps; +with Report; + +procedure CXA4006 is + +begin + + Report.Test ("CXA4006", "Check that the subprograms defined in package " & + "Ada.Strings.Bounded are available, and that " & + "they produce correct results"); + + Test_Block: + declare + + Characters_Per_Line : constant Positive := 40; + Lines_Per_Page : constant Natural := 4; + + package BS_40 is new + Ada.Strings.Bounded.Generic_Bounded_Length(Characters_Per_Line); + use type BS_40.Bounded_String; + + type Page_Type is array (1..Lines_Per_Page) of BS_40.Bounded_String; + + -- Note: Misspellings below are intentional. + + Line1 : BS_40.Bounded_String := + BS_40.To_Bounded_String("ada is a progrraming language designed"); + Line2 : BS_40.Bounded_String := + BS_40.To_Bounded_String("to support the construction of long-"); + Line3 : BS_40.Bounded_String := + BS_40.To_Bounded_String("lived, highly reliabel software "); + Line4 : BS_40.Bounded_String := + BS_40.To_Bounded_String("systems"); + + Page : Page_Type := (1 => Line1, 2 => Line2, 3 => Line3, 4 => Line4); + + Finished_Page : Page_Type := + (BS_40.To_Bounded_String("Ada is a programming language designed"), + BS_40.To_Bounded_String("to support the construction of long-"), + BS_40.To_Bounded_String("lived, HIGHLY RELIABLE software systems."), + BS_40.To_Bounded_String("")); + + --- + + procedure Compress (Page : in out Page_Type) is + Clear_Line : Natural := Lines_Per_Page; + begin + -- If two consecutive lines on the page are together less than the + -- maximum line length, then append those two lines, move up all + -- lower lines on the page, and blank out the last line. + for i in 1..Lines_Per_Page - 1 loop + if BS_40.Length(Page(i)) + BS_40.Length(Page(i+1)) <= + BS_40.Max_Length + then + Page(i) := BS_40."&"(Page(i), + Page(i+1)); -- "&" (bounded, bounded) + + for j in i+1..Lines_Per_Page - 1 loop + Page(j) := + BS_40.To_Bounded_String + (BS_40.Slice(Page(j+1), + 1, + BS_40.Length(Page(j+1)))); + Clear_Line := j + 1; + end loop; + Page(Clear_Line) := BS_40.Null_Bounded_String; + end if; + end loop; + end Compress; + + --- + + procedure Format (Page : in out Page_Type) is + Sm_Ada : BS_40.Bounded_String := BS_40.To_Bounded_String("ada"); + Cap_Ada : constant String := "Ada"; + Char_Pos : Natural := 0; + Finished : Boolean := False; + Line : Natural := Page_Type'Last; + begin + + -- Add a period to the end of the last line. + while Line >= Page_Type'First and not Finished loop + if Page(Line) /= BS_40.Null_Bounded_String and + BS_40.Length(Page(Line)) <= BS_40.Max_Length + then + Page(Line) := BS_40.Append(Page(Line), '.'); + Finished := True; + end if; + Line := Line - 1; + end loop; + + -- Replace all occurrences of "ada" with "Ada". + for Line in Page_Type'First .. Page_Type'Last loop + Finished := False; + while not Finished loop + Char_Pos := BS_40.Index(Source => Page(Line), + Pattern => BS_40.To_String(Sm_Ada), + Going => Ada.Strings.Backward); + -- A zero is returned by function Index if no occurrences of + -- the pattern string are found. + Finished := (Char_Pos = 0); + if not Finished then + BS_40.Replace_Slice + (Source => Page(Line), + Low => Char_Pos, + High => Char_Pos + BS_40.Length(Sm_Ada) - 1, + By => Cap_Ada); + end if; + end loop; -- while loop + end loop; -- for loop + + end Format; + + --- + + procedure Spell_Check (Page : in out Page_Type) is + type Spelling_Type is (Incorrect, Correct); + type Word_Array_Type is array (Spelling_Type) + of BS_40.Bounded_String; + type Dictionary_Type is array (1..2) of Word_Array_Type; + + -- Note that the "words" in the dictionary will require various + -- amounts of Trimming prior to their use in the string functions. + Dictionary : Dictionary_Type := + (1 => (BS_40.To_Bounded_String(" reliabel "), + BS_40.To_Bounded_String(" reliable ")), + 2 => (BS_40.To_Bounded_String(" progrraming "), + BS_40.To_Bounded_String(" programming "))); + + Pos : Natural := Natural'First; + Finished : Boolean := False; + + begin + + for Line in Page_Type'Range loop + + -- Search for the first incorrectly spelled word in the Dictionary, + -- if it is found, replace it with the correctly spelled word, + -- using the Overwrite function. + + while not Finished loop + Pos := + BS_40.Index(Page(Line), + BS_40.To_String( + BS_40.Trim(Dictionary(1)(Incorrect), + Ada.Strings.Both)), + Ada.Strings.Forward); + Finished := (Pos = 0); + if not Finished then + Page(Line) := + BS_40.Overwrite(Page(Line), + Pos, + BS_40.To_String + (BS_40.Trim(Dictionary(1)(Correct), + Ada.Strings.Both))); + end if; + end loop; + + Finished := False; + + -- Search for the second incorrectly spelled word in the + -- Dictionary, if it is found, replace it with the correctly + -- spelled word, using the Delete procedure and Insert function. + + while not Finished loop + Pos := + BS_40.Index(Page(Line), + BS_40.To_String( + BS_40.Trim(Dictionary(2)(Incorrect), + Ada.Strings.Both)), + Ada.Strings.Forward); + + Finished := (Pos = 0); + + if not Finished then + BS_40.Delete + (Page(Line), + Pos, + Pos + BS_40.To_String + (BS_40.Trim(Dictionary(2)(Incorrect), + Ada.Strings.Both))'Length-1); + Page(Line) := + BS_40.Insert(Page(Line), + Pos, + BS_40.To_String + (BS_40.Trim(Dictionary(2)(Correct), + Ada.Strings.Both))); + end if; + end loop; + + Finished := False; + + end loop; + end Spell_Check; + + --- + + procedure Bold (Page : in out Page_Type) is + Key_Word : constant String := "highly reliable"; + Bold_Mapping : constant Ada.Strings.Maps.Character_Mapping := + Ada.Strings.Maps.To_Mapping(From => " abcdefghijklmnopqrstuvwxyz", + To => " ABCDEFGHIJKLMNOPQRSTUVWXYZ"); + Pos : Natural := Natural'First; + Finished : Boolean := False; + begin + -- This procedure is designed to change the case of the phrase + -- "highly reliable" into upper case (a type of "Bolding"). + -- All instances of the phrase on all lines of the page will be + -- modified. + + for Line in Page_Type'First .. Page_Type'Last loop + while not Finished loop + Pos := BS_40.Index(Page(Line), Key_Word); + Finished := (Pos = 0); + if not Finished then + + BS_40.Overwrite + (Page(Line), + Pos, + BS_40.To_String + (BS_40.Translate + (BS_40.To_Bounded_String + (BS_40.Slice(Page(Line), + Pos, + Pos + Key_Word'Length - 1)), + Bold_Mapping))); + + end if; + end loop; + Finished := False; + end loop; + end Bold; + + + begin + + Compress(Page); + Format(Page); + Spell_Check(Page); + Bold(Page); + + for i in 1..Lines_Per_Page loop + if BS_40.To_String(Page(i)) /= BS_40.To_String(Finished_Page(i)) or + BS_40.Length(Page(i)) /= BS_40.Length(Finished_Page(i)) + then + Report.Failed("Incorrect modification of Page, Line " & + Integer'Image(i)); + end if; + end loop; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + + Report.Result; + +end CXA4006; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4007.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4007.a new file mode 100644 index 000000000..fca15d367 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4007.a @@ -0,0 +1,334 @@ +-- CXA4007.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 subprograms defined in package Ada.Strings.Bounded are +-- available, and that they produce correct results. Specifically, check +-- the subprograms Append, Count, Element, Find_Token, Head, +-- Index_Non_Blank, Replace_Element, Replicate, Tail, To_Bounded_String, +-- "&", ">", "<", ">=", "<=", and "*". +-- +-- TEST DESCRIPTION: +-- This test, when taken in conjunction with tests CXA400[6,8,9], will +-- constitute a test of all the functionality contained in package +-- Ada.Strings.Bounded. This test uses a variety of the +-- subprograms defined in the bounded string package in ways typical +-- of common usage. Different combinations of available subprograms +-- are used to accomplish similar bounded string processing goals. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 22 Dec 94 SAIC Changed obsolete constant to Ada.Strings.Space. +-- +--! + +with Ada.Strings; +with Ada.Strings.Bounded; +with Ada.Strings.Maps; +with Report; + +procedure CXA4007 is + +begin + + Report.Test ("CXA4007", "Check that the subprograms defined in package " & + "Ada.Strings.Bounded are available, and that " & + "they produce correct results"); + + Test_Block: + declare + + package BS80 is new Ada.Strings.Bounded.Generic_Bounded_Length(80); + use type BS80.Bounded_String; + + Part1 : constant String := "Rum"; + Part2 : Character := 'p'; + Part3 : BS80.Bounded_String := BS80.To_Bounded_String("el"); + Part4 : Character := 's'; + Part5 : BS80.Bounded_String := BS80.To_Bounded_String("tilt"); + Part6 : String(1..3) := "ski"; + + Full_Catenate_String, + Full_Append_String, + Constructed_String, + Drop_String, + Replicated_String, + Token_String : BS80.Bounded_String; + + CharA : Character := 'A'; + CharB : Character := 'B'; + CharC : Character := 'C'; + CharD : Character := 'D'; + CharE : Character := 'E'; + CharF : Character := 'F'; + + ABStr : String(1..15) := "AAAAABBBBBBBBBB"; + StrB : String(1..2) := "BB"; + StrE : String(1..2) := "EE"; + + + begin + + -- Evaluation of the overloaded forms of the "&" operator defined + -- for instantiations of Bounded Strings. + + Full_Catenate_String := + BS80."&"(Part2, -- Char & Bnd Str + BS80."&"(Part3, -- Bnd Str & Bnd Str + BS80."&"(Part4, -- Char & Bnd Str + BS80."&"(Part5, -- Bnd Str & Bnd Str + BS80.To_Bounded_String(Part6))))); + + Full_Catenate_String := + Part1 & Full_Catenate_String; -- Str & Bnd Str + Full_Catenate_String := + Full_Catenate_String & 'n'; -- Bnd Str & Char + + + -- Evaluation of the overloaded forms of function Append. + + Full_Append_String := + BS80.Append(Part2, -- Char,Bnd + BS80.Append(Part3, -- Bnd, Bnd + BS80.Append(Part4, -- Char,Bnd + BS80.Append(BS80.To_String(Part5), -- Str,Bnd + BS80.To_Bounded_String(Part6))))); + + Full_Append_String := + BS80.Append(BS80.To_Bounded_String(Part1), -- Bnd , Str + BS80.To_String(Full_Append_String)); + + Full_Append_String := + BS80.Append(Left => Full_Append_String, + Right => 'n'); -- Bnd, Char + + + -- Validate the resulting bounded strings. + + if Full_Catenate_String < Full_Append_String or + Full_Catenate_String > Full_Append_String or + not (Full_Catenate_String = Full_Append_String and + Full_Catenate_String <= Full_Append_String and + Full_Catenate_String >= Full_Append_String) + then + Report.Failed("Incorrect results from bounded string catenation" & + " and comparison"); + end if; + + + -- Evaluate the overloaded forms of the Constructor function "*" and + -- the Replicate function. + + Constructed_String := + (2 * CharA) & -- "AA" + (2 * StrB) & -- "AABBBB" + (3 * BS80."*"(2, CharC)) & -- "AABBBBCCCCCC" + BS80.Replicate(3, + BS80.Replicate(2, CharD)) & -- "AABBBBCCCCCCDDDDDD" + BS80.Replicate(2, StrE) & -- "AABBBBCCCCCCDDDDDDEEEE" + BS80.Replicate(2, CharF); -- "AABBBBCCCCCCDDDDDDEEEEFF" + + + -- Use of Function Replicate that involves dropping characters. The + -- attempt to replicate the 15 character string six times will exceed + -- the 80 character bound of the string. Therefore, the result should + -- be the catenation of 5 copies of the 15 character string, followed + -- by 5 'A' characters (the first five characters of the 6th + -- replication) with the remaining characters of the 6th replication + -- dropped. + + Drop_String := + BS80.Replicate(Count => 6, + Item => ABStr, -- "AAAAABBBBBBBBBB" + Drop => Ada.Strings.Right); + + if BS80.Element(Drop_String, 1) /= 'A' or + BS80.Element(Drop_String, 6) /= 'B' or + BS80.Element(Drop_String, 76) /= 'A' or + BS80.Element(Drop_String, 80) /= 'A' + then + Report.Failed("Incorrect result from Replicate with Drop"); + end if; + + + -- Use function Index_Non_Blank in the evaluation of the + -- Constructed_String. + + if BS80.Index_Non_Blank(Constructed_String, Ada.Strings.Forward) /= + BS80.To_String(Constructed_String)'First or + BS80.Index_Non_Blank(Constructed_String, Ada.Strings.Backward) /= + BS80.Length(Constructed_String) + then + Report.Failed("Incorrect results from constructor functions"); + end if; + + + + declare + + -- Define character set objects for use with the Count function. + -- Constructed_String = "AABBBBCCCCCCDDDDDDEEEEFF" from above. + + A_Set : Ada.Strings.Maps.Character_Set := + Ada.Strings.Maps.To_Set(BS80.Element(Constructed_String,1)); + B_Set : Ada.Strings.Maps.Character_Set := + Ada.Strings.Maps.To_Set(BS80.Element(Constructed_String,3)); + C_Set : Ada.Strings.Maps.Character_Set := + Ada.Strings.Maps.To_Set(BS80.Element(Constructed_String,7)); + D_Set : Ada.Strings.Maps.Character_Set := + Ada.Strings.Maps.To_Set(BS80.Element(Constructed_String,13)); + E_Set : Ada.Strings.Maps.Character_Set := + Ada.Strings.Maps.To_Set(BS80.Element(Constructed_String,19)); + F_Set : Ada.Strings.Maps.Character_Set := + Ada.Strings.Maps.To_Set(BS80.Element(Constructed_String,23)); + + + Start : Positive; + Stop : Natural := 0; + + begin + + -- Evaluate the results from function Count by comparing the number + -- of A's to the number of F's, B's to E's, and C's to D's in the + -- Constructed_String. + -- There should be an equal number of each of the characters that + -- are being compared (i.e., 2 A's and F's, 4 B's and E's, etc) + + if BS80.Count(Constructed_String, A_Set) /= + BS80.Count(Constructed_String, F_Set) or + BS80.Count(Constructed_String, B_Set) /= + BS80.Count(Constructed_String, E_Set) or + not (BS80.Count(Constructed_String, C_Set) = + BS80.Count(Constructed_String, D_Set)) + then + Report.Failed("Incorrect result from function Count"); + end if; + + + -- Evaluate the functions Head, Tail, and Find_Token. + -- Create the Token_String from the Constructed_String above. + + Token_String := + BS80.Tail(BS80.Head(Constructed_String, 3), 2) & -- "AB" & + BS80.Head(BS80.Tail(Constructed_String, 13), 2) & -- "CD" & + BS80.Head(BS80.Tail(Constructed_String, 3), 2); -- "EF" + + if Token_String /= BS80.To_Bounded_String("ABCDEF") then + Report.Failed("Incorrect result from Catenation of Token_String"); + end if; + + + -- Find the starting/ending position of the first A in the + -- Token_String (both should be 1, only one A appears in string). + -- The Function Head uses the default pad character to return a + -- bounded string longer than its input parameter bounded string. + + BS80.Find_Token(BS80.Head(Token_String, 10), -- Default pad. + A_Set, + Ada.Strings.Inside, + Start, + Stop); + + if Start /= 1 and Stop /= 1 then + Report.Failed("Incorrect result from Find_Token - 1"); + end if; + + + -- Find the starting/ending position of the first non-AB slice in + -- the "head" five characters of Token_String (slice CDE at + -- positions 3-5) + + BS80.Find_Token(BS80.Head(Token_String, 5), -- "ABCDE" + Ada.Strings.Maps."OR"(A_Set, B_Set), -- Set (AB) + Ada.Strings.Outside, + Start, + Stop); + + if Start /= 3 and Stop /= 5 then + Report.Failed("Incorrect result from Find_Token - 2"); + end if; + + + -- Find the starting/ending position of the first CD slice in + -- the "tail" eight characters (including two pad characters) + -- of Token_String (slice CD at positions 5-6 of the tail + -- portion specified) + + BS80.Find_Token(BS80.Tail(Token_String, 8, + Ada.Strings.Space), -- " ABCDEF" + Ada.Strings.Maps."OR"(C_Set, D_Set), -- Set (CD) + Ada.Strings.Inside, + Start, + Stop); + + if Start /= 5 and Stop /= 6 then + Report.Failed("Incorrect result from Find_Token - 3"); + end if; + + + -- Evaluate the Replace_Element procedure. + + -- Token_String = "ABCDEF" + + BS80.Replace_Element(Token_String, 3, BS80.Element(Token_String,4)); + + -- Token_String = "ABDDEF" + + BS80.Replace_Element(Source => Token_String, + Index => 2, + By => BS80.Element(Token_String, 5)); + + -- Token_String = "AEDDEF" + + BS80.Replace_Element(Token_String, + 1, + BS80.Element(BS80.Tail(Token_String, 2), 2)); + + -- Token_String = "FEDDEF" + -- Evaluate this result. + + if BS80.Element(Token_String, BS80.To_String(Token_String)'First) /= + BS80.Element(Token_String, BS80.To_String(Token_String)'Last) or + BS80.Count(Token_String, D_Set) /= + BS80.Count(Token_String, E_Set) or + BS80.Index_Non_Blank(BS80.Head(Token_String,6)) /= + BS80.Index_Non_Blank(BS80.Tail(Token_String,6)) or + BS80.Head(Token_String, 1) /= + BS80.Tail(Token_String, 1) + then + Report.Failed("Incorrect result from operations in combination"); + end if; + + end; + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + + Report.Result; + +end CXA4007; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4008.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4008.a new file mode 100644 index 000000000..629305f76 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4008.a @@ -0,0 +1,662 @@ +-- CXA4008.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 subprograms defined in package Ada.Strings.Bounded are +-- available, and that they produce correct results, especially under +-- conditions where truncation of the result is required. Specifically, +-- check the subprograms Append, Count with non-Identity maps, Index with +-- non-Identity maps, Index with Set parameters, Insert (function and +-- procedure), Replace_Slice (function and procedure), To_Bounded_String, +-- and Translate. +-- +-- TEST DESCRIPTION: +-- This test, in conjunction with tests CXA4006, CXA4007, and CXA4009, +-- will provide coverage of the most common usages of the functionality +-- found in the Ada.Strings.Bounded package. It deals in large part +-- with truncation effects and options. This test contains many small, +-- specific test cases, situations that are often difficult to generate +-- in large numbers in an application-based test. These cases represent +-- specific usage paradigms in-the-small. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 10 Apr 95 SAIC Corrected acceptance condition of subtest for +-- Function Append with Truncation = Left. +-- 31 Oct 95 SAIC Update and repair for ACVC 2.0.1. +-- +--! + +with Report; +with Ada.Strings.Maps.Constants; +with Ada.Strings.Bounded; +with Ada.Strings.Maps; + +procedure CXA4008 is + +begin + + Report.Test("CXA4008", "Check that the subprograms defined in " & + "package Ada.Strings.Bounded are available, " & + "and that they produce correct results, " & + "especially under conditions where " & + "truncation of the result is required"); + + Test_Block: + declare + + package AS renames Ada.Strings; + package ASB renames Ada.Strings.Bounded; + package ASC renames Ada.Strings.Maps.Constants; + package Maps renames Ada.Strings.Maps; + + package B10 is new ASB.Generic_Bounded_Length(Max => 10); + use type B10.Bounded_String; + + Result_String : B10.Bounded_String; + Test_String : B10.Bounded_String; + AtoE_Bnd_Str : B10.Bounded_String := B10.To_Bounded_String("abcde"); + FtoJ_Bnd_Str : B10.Bounded_String := B10.To_Bounded_String("fghij"); + AtoJ_Bnd_Str : B10.Bounded_String := + B10.To_Bounded_String("abcdefghij"); + + Location : Natural := 0; + Total_Count : Natural := 0; + + CD_Set : Maps.Character_Set := Maps.To_Set("cd"); + + AB_to_YZ_Map : Maps.Character_Mapping := + Maps.To_Mapping(From => "ab", To => "yz"); + + CD_to_XY_Map : Maps.Character_Mapping := + Maps.To_Mapping(From => "cd", To => "xy"); + + + begin + -- Function To_Bounded_String with Truncation + -- Evaluate the function Append with parameters that will + -- cause the truncation of the result. + + -- Drop = Error (default case, Length_Error will be raised) + + begin + Test_String := + B10.To_Bounded_String("Much too long for this bounded string"); + Report.Failed("Length Error not raised by To_Bounded_String"); + exception + when AS.Length_Error => null; -- Expected exception raised. + when others => + Report.Failed("Incorrect exception raised by To_Bounded_String"); + end; + + -- Drop = Left + + Test_String := B10.To_Bounded_String(Source => "abcdefghijklmn", + Drop => Ada.Strings.Left); + + if Test_String /= B10.To_Bounded_String("efghijklmn") then + Report.Failed + ("Incorrect result from To_Bounded_String, Drop = Left"); + end if; + + -- Drop = Right + + Test_String := B10.To_Bounded_String(Source => "abcdefghijklmn", + Drop => Ada.Strings.Right); + + if not(Test_String = AtoJ_Bnd_Str) then + Report.Failed + ("Incorrect result from To_Bounded_String, Drop = Right"); + end if; + + + + + -- Function Append with Truncation + -- Evaluate the function Append with parameters that will + -- cause the truncation of the result. + + -- Drop = Error (default case, Length_Error will be raised) + + begin + -- Append (Bnd Str, Bnd Str); + Result_String := + B10.Append(B10.To_Bounded_String("abcde"), + B10.To_Bounded_String("fghijk")); -- 11 char + Report.Failed("Length_Error not raised by Append - 1"); + exception + when AS.Length_Error => null; -- OK, correct exception raised. + when others => + Report.Failed("Incorrect exception raised by Append - 1"); + end; + + begin + -- Append (Str, Bnd Str); + Result_String := B10.Append(B10.To_String(AtoE_Bnd_Str), + B10.To_Bounded_String("fghijk"), + AS.Error); + Report.Failed("Length_Error not raised by Append - 2"); + exception + when AS.Length_Error => null; -- OK, correct exception raised. + when others => + Report.Failed("Incorrect exception raised by Append - 2"); + end; + + begin + -- Append (Bnd Str, Char); + Result_String := + B10.Append(B10.To_Bounded_String("abcdefghij"), 'k'); + Report.Failed("Length_Error not raised by Append - 3"); + exception + when AS.Length_Error => null; -- OK, correct exception raised. + when others => + Report.Failed("Incorrect exception raised by Append - 3"); + end; + + -- Drop = Left + + -- Append (Bnd Str, Bnd Str) + Result_String := B10.Append(B10.To_Bounded_String("abcdefgh"), -- 8 chs + B10.To_Bounded_String("ijklmn"), -- 6 chs + Ada.Strings.Left); + + if Result_String /= B10.To_Bounded_String("efghijklmn") then -- 10 chars + Report.Failed("Incorrect truncation performed by Append - 4"); + end if; + + -- Append (Bnd Str, Str) + Result_String := + B10.Append(B10.To_Bounded_String("abcdefghij"), + "xyz", + Ada.Strings.Left); + + if Result_String /= B10.To_Bounded_String("defghijxyz") then + Report.Failed("Incorrect truncation performed by Append - 5"); + end if; + + -- Append (Char, Bnd Str) + + Result_String := B10.Append('A', + B10.To_Bounded_String("abcdefghij"), + Ada.Strings.Left); + + if Result_String /= B10.To_Bounded_String("abcdefghij") then + Report.Failed("Incorrect truncation performed by Append - 6"); + end if; + + -- Drop = Right + + -- Append (Bnd Str, Bnd Str) + Result_String := B10.Append(FtoJ_Bnd_Str, + AtoJ_Bnd_Str, + Ada.Strings.Right); + + if Result_String /= B10.To_Bounded_String("fghijabcde") then + Report.Failed("Incorrect truncation performed by Append - 7"); + end if; + + -- Append (Str, Bnd Str) + Result_String := B10.Append(B10.To_String(AtoE_Bnd_Str), + AtoJ_Bnd_Str, + Ada.Strings.Right); + + if Result_String /= B10.To_Bounded_String("abcdeabcde") then + Report.Failed("Incorrect truncation performed by Append - 8"); + end if; + + -- Append (Char, Bnd Str) + Result_String := B10.Append('A', AtoJ_Bnd_Str, Ada.Strings.Right); + + if Result_String /= B10.To_Bounded_String("Aabcdefghi") then + Report.Failed("Incorrect truncation performed by Append - 9"); + end if; + + + -- Function Index with non-Identity map. + -- Evaluate the function Index with a non-identity map + -- parameter which will cause mapping of the source parameter + -- prior to the evaluation of the index position search. + + Location := B10.Index(Source => AtoJ_Bnd_Str, -- "abcdefghij" + Pattern => "xy", + Going => Ada.Strings.Forward, + Mapping => CD_to_XY_Map); -- change "cd" to "xy" + + if Location /= 3 then + Report.Failed("Incorrect result from Index, non-Identity map - 1"); + end if; + + Location := B10.Index(B10.To_Bounded_String("AND IF MAN"), + "an", + Ada.Strings.Backward, + ASC.Lower_Case_Map); + + if Location /= 9 then + Report.Failed("Incorrect result from Index, non-Identity map - 2"); + end if; + + Location := B10.Index(Source => B10.To_Bounded_String("The the"), + Pattern => "the", + Going => Ada.Strings.Forward, + Mapping => ASC.Lower_Case_Map); + + if Location /= 1 then + Report.Failed("Incorrect result from Index, non-Identity map - 3"); + end if; + + + if B10.Index(B10.To_Bounded_String("abcd"), -- Pattern = Source + "abcd") /= 1 or + B10.Index(B10.To_Bounded_String("abc"), -- Pattern < Source + "abcd") /= 0 or + B10.Index(B10.Null_Bounded_String, -- Source = Null + "abc") /= 0 + then + Report.Failed("Incorrect result from Index with string patterns"); + end if; + + + -- Function Index (for Sets). + -- This version of Index uses Sets as the basis of the search. + + -- Test = Inside, Going = Forward (Default case). + Location := + B10.Index(Source => B10.To_Bounded_String("abcdeabcde"), + Set => CD_Set, -- set containing 'c' and 'd' + Test => Ada.Strings.Inside, + Going => Ada.Strings.Forward); + + if not (Location = 3) then -- position of first 'c' in source. + Report.Failed("Incorrect result from Index using Sets - 1"); + end if; + + -- Test = Inside, Going = Backward. + Location := + B10.Index(Source => B10."&"(AtoE_Bnd_Str, AtoE_Bnd_Str), + Set => CD_Set, -- set containing 'c' and 'd' + Test => Ada.Strings.Inside, + Going => Ada.Strings.Backward); + + if not (Location = 9) then -- position of last 'd' in source. + Report.Failed("Incorrect result from Index using Sets - 2"); + end if; + + -- Test = Outside, Going = Forward. + Location := B10.Index(B10.To_Bounded_String("deddacd"), + CD_Set, + Test => Ada.Strings.Outside, + Going => Ada.Strings.Forward); + + if Location /= 2 then -- position of 'e' in source. + Report.Failed("Incorrect result from Index using Sets - 3"); + end if; + + -- Test = Outside, Going = Backward. + Location := B10.Index(B10.To_Bounded_String("deddacd"), + CD_Set, + Ada.Strings.Outside, + Ada.Strings.Backward); + + if Location /= 5 then -- correct position of 'a'. + Report.Failed("Incorrect result from Index using Sets - 4"); + end if; + + if B10.Index(B10.To_Bounded_String("cd"), -- Source = Set + CD_Set) /= 1 or + B10.Index(B10.To_Bounded_String("c"), -- Source < Set + CD_Set) /= 1 or + B10.Index(B10.Null_Bounded_String, -- Source = Null + CD_Set) /= 0 or + B10.Index(AtoE_Bnd_Str, -- "abcde" + Maps.Null_Set) /= 0 or -- Null set + B10.Index(AtoE_Bnd_Str, + Maps.To_Set('x')) /= 0 -- No match. + then + Report.Failed("Incorrect result from Index using Sets - 5"); + end if; + + + -- Function Count with non-Identity mapping. + -- Evaluate the function Count with a non-identity map + -- parameter which will cause mapping of the source parameter + -- prior to the evaluation of the number of matching patterns. + + Total_Count := + B10.Count(Source => B10.To_Bounded_String("abbabaabab"), + Pattern => "yz", + Mapping => AB_to_YZ_Map); + + if Total_Count /= 4 then + Report.Failed + ("Incorrect result from function Count, non-Identity map - 1"); + end if; + + -- And a few with identity maps as well. + + if B10.Count(B10.To_Bounded_String("ABABABABAB"), + "ABA", + Maps.Identity) /= 2 or + B10.Count(B10.To_Bounded_String("ADCBADABCD"), + "AB", + Maps.To_Mapping("CD", "AB")) /= 5 or + B10.Count(B10.To_Bounded_String("aaaaaaaaaa"), + "aaa") /= 3 or + B10.Count(B10.To_Bounded_String("XX"), -- Source < Pattern + "XXX", + Maps.Identity) /= 0 or + B10.Count(AtoE_Bnd_Str, -- Source = Pattern + "abcde") /= 1 or + B10.Count(B10.Null_Bounded_String, -- Source = Null + " ") /= 0 + then + Report.Failed + ("Incorrect result from function Count, w,w/o mapping"); + end if; + + + -- Procedure Translate + + -- Partial mapping of source. + + Test_String := B10.To_Bounded_String("abcdeabcab"); + + B10.Translate(Source => Test_String, Mapping => AB_to_YZ_Map); + + if Test_String /= B10.To_Bounded_String("yzcdeyzcyz") then + Report.Failed("Incorrect result from procedure Translate - 1"); + end if; + + -- Total mapping of source. + + Test_String := B10.To_Bounded_String("abbaaababb"); + + B10.Translate(Source => Test_String, Mapping => ASC.Upper_Case_Map); + + if Test_String /= B10.To_Bounded_String("ABBAAABABB") then + Report.Failed("Incorrect result from procedure Translate - 2"); + end if; + + -- No mapping of source. + + Test_String := B10.To_Bounded_String("xyzsypcc"); + + B10.Translate(Source => Test_String, Mapping => AB_to_YZ_Map); + + if Test_String /= B10.To_Bounded_String("xyzsypcc") then + Report.Failed("Incorrect result from procedure Translate - 3"); + end if; + + -- Map > 2 characters, partial mapping. + + Test_String := B10.To_Bounded_String("have faith"); + + B10.Translate(Test_String, + Maps.To_Mapping("aeiou", "AEIOU")); + + if Test_String /= B10.To_Bounded_String("hAvE fAIth") then + Report.Failed("Incorrect result from procedure Translate - 4"); + end if; + + + -- Function Replace_Slice + -- Evaluate function Replace_Slice with + -- a variety of Truncation options. + + -- Drop = Error (Default) + + begin + Test_String := AtoJ_Bnd_Str; + Result_String := + B10.Replace_Slice(Source => Test_String, -- "abcdefghij" + Low => 3, + High => 5, -- 3-5, 3 chars. + By => "xxxxxx"); -- more than 3. + Report.Failed("Length_Error not raised by Function Replace_Slice"); + exception + when AS.Length_Error => null; -- Correct exception raised. + when others => + Report.Failed + ("Incorrect exception raised by Function Replace_Slice"); + end; + + -- Drop = Left + + Result_String := + B10.Replace_Slice(Source => Test_String, -- "abcdefghij" + Low => 7, + High => 10, -- 7-10, 4 chars. + By => "xxxxxx", -- 6 chars. + Drop => Ada.Strings.Left); + + if Result_String /= B10.To_Bounded_String("cdefxxxxxx") then -- drop a,b + Report.Failed + ("Incorrect result from Function Replace Slice, Drop = Left"); + end if; + + -- Drop = Right + + Result_String := + B10.Replace_Slice(Source => Test_String, -- "abcdefghij" + Low => 2, + High => 5, -- 2-5, 4 chars. + By => "xxxxxx", -- 6 chars. + Drop => Ada.Strings.Right); + + if Result_String /= B10.To_Bounded_String("axxxxxxfgh") then -- drop i,j + Report.Failed + ("Incorrect result from Function Replace Slice, Drop = Right"); + end if; + + -- Low = High = Source'Last, "By" length = 1. + + if B10.Replace_Slice(AtoE_Bnd_Str, + B10.To_String(AtoE_Bnd_Str)'Last, + B10.To_String(AtoE_Bnd_Str)'Last, + "X", + Ada.Strings.Error) /= + B10.To_Bounded_String("abcdX") + then + Report.Failed("Incorrect result from Function Replace_Slice"); + end if; + + + + -- Procedure Replace_Slice + -- Evaluate procedure Replace_Slice with + -- a variety of Truncation options. + + -- Drop = Error (Default) + + begin + Test_String := AtoJ_Bnd_Str; + B10.Replace_Slice(Source => Test_String, -- "abcdefghij" + Low => 3, + High => 5, -- 3-5, 3 chars. + By => "xxxxxx"); -- more than 3. + Report.Failed("Length_Error not raised by Procedure Replace_Slice"); + exception + when AS.Length_Error => null; -- Correct exception raised. + when others => + Report.Failed + ("Incorrect exception raised by Procedure Replace_Slice"); + end; + + -- Drop = Left + + Test_String := AtoJ_Bnd_Str; + B10.Replace_Slice(Source => Test_String, -- "abcdefghij" + Low => 7, + High => 9, -- 7-9, 3 chars. + By => "xxxxx", -- 5 chars. + Drop => Ada.Strings.Left); + + if Test_String /= B10.To_Bounded_String("cdefxxxxxj") then -- drop a,b + Report.Failed + ("Incorrect result from Procedure Replace Slice, Drop = Left"); + end if; + + -- Drop = Right + + Test_String := AtoJ_Bnd_Str; + B10.Replace_Slice(Source => Test_String, -- "abcdefghij" + Low => 1, + High => 3, -- 1-3, 3chars. + By => "xxxx", -- 4 chars. + Drop => Ada.Strings.Right); + + if Test_String /= B10.To_Bounded_String("xxxxdefghi") then -- drop j + Report.Failed + ("Incorrect result from Procedure Replace Slice, Drop = Right"); + end if; + + -- High = Source'First, Low > High (Insert before Low). + + Test_String := AtoE_Bnd_Str; + B10.Replace_Slice(Source => Test_String, -- "abcde" + Low => B10.To_String(Test_String)'Last, + High => B10.To_String(Test_String)'First, + By => "XXXX", -- 4 chars. + Drop => Ada.Strings.Right); + + if Test_String /= B10.To_Bounded_String("abcdXXXXe") then + Report.Failed + ("Incorrect result from Procedure Replace Slice"); + end if; + + + + -- Function Insert with Truncation + -- Drop = Error (Default). + + begin + Result_String := + B10.Insert(Source => AtoJ_Bnd_Str, -- "abcdefghij" + Before => 2, + New_Item => "xyz"); + Report.Failed("Length_Error not raised by Function Insert"); + exception + when AS.Length_Error => null; -- Correct exception raised. + when others => + Report.Failed("Incorrect exception raised by Function Insert"); + end; + + -- Drop = Left + + Result_String := + B10.Insert(Source => AtoJ_Bnd_Str, -- "abcdefghij" + Before => 5, + New_Item => "xyz", -- 3 additional chars. + Drop => Ada.Strings.Left); + + if B10.To_String(Result_String) /= "dxyzefghij" then -- drop a, b, c + Report.Failed("Incorrect result from Function Insert, Drop = Left"); + end if; + + -- Drop = Right + + Result_String := + B10.Insert(Source => B10.To_Bounded_String("abcdef"), + Before => 2, + New_Item => "vwxyz", -- 5 additional chars. + Drop => Ada.Strings.Right); + + if B10.To_String(Result_String) /= "avwxyzbcde" then -- drop f. + Report.Failed("Incorrect result from Function Insert, Drop = Right"); + end if; + + -- Additional cases. + + if B10.Insert(B10.To_Bounded_String("a"), 1, " B") /= + B10.To_Bounded_String(" Ba") or + B10.Insert(B10.Null_Bounded_String, 1, "abcde") /= + AtoE_Bnd_Str or + B10.Insert(B10.To_Bounded_String("ab"), 2, "") /= + B10.To_Bounded_String("ab") + then + Report.Failed("Incorrect result from Function Insert"); + end if; + + + -- Procedure Insert + + -- Drop = Error (Default). + begin + Test_String := AtoJ_Bnd_Str; + B10.Insert(Source => Test_String, -- "abcdefghij" + Before => 9, + New_Item => "wxyz", + Drop => Ada.Strings.Error); + Report.Failed("Length_Error not raised by Procedure Insert"); + exception + when AS.Length_Error => null; -- Correct exception raised. + when others => + Report.Failed("Incorrect exception raised by Procedure Insert"); + end; + + -- Drop = Left + + Test_String := AtoJ_Bnd_Str; + B10.Insert(Source => Test_String, -- "abcdefghij" + Before => B10.Length(Test_String), -- before last char + New_Item => "xyz", -- 3 additional chars. + Drop => Ada.Strings.Left); + + if B10.To_String(Test_String) /= "defghixyzj" then -- drop a, b, c + Report.Failed("Incorrect result from Procedure Insert, Drop = Left"); + end if; + + -- Drop = Right + + Test_String := AtoJ_Bnd_Str; + B10.Insert(Source => Test_String, + Before => 4, + New_Item => "yz", -- 2 additional chars. + Drop => Ada.Strings.Right); + + if B10.To_String(Test_String) /= "abcyzdefgh" then -- drop i,j + Report.Failed + ("Incorrect result from Procedure Insert, Drop = Right"); + end if; + + -- Before = Source'First, New_Item length = 1. + + Test_String := B10.To_Bounded_String(" abc "); + B10.Insert(Test_String, + B10.To_String(Test_String)'First, + "Z"); + + if Test_String /= B10.To_Bounded_String("Z abc ") then + Report.Failed("Incorrect result from Procedure Insert"); + end if; + + + exception + when others => Report.Failed("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + +end CXA4008; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4009.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4009.a new file mode 100644 index 000000000..f02ef0365 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4009.a @@ -0,0 +1,619 @@ +-- CXA4009.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 subprograms defined in package Ada.Strings.Bounded are +-- available, and that they produce correct results, especially under +-- conditions where truncation of the result is required. Specifically, +-- check the subprograms Overwrite (function and procedure), Delete, +-- Function Trim (blanks), Trim (Set characters, function and procedure), +-- Head, Tail, and Replicate (characters and strings). +-- +-- TEST DESCRIPTION: +-- This test, in conjunction with tests CXA4006, CXA4007, and CXA4008, +-- will provide coverage of the most common usages of the functionality +-- found in the Ada.Strings.Bounded package. It deals in large part +-- with truncation effects and options. This test contains many small, +-- specific test cases, situations that are often difficult to generate +-- in large numbers in an application-based test. These cases represent +-- specific usage paradigms in-the-small. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 10 Apr 95 SAIC Corrected errors in Procedure Overwrite subtests. +-- 01 Nov 95 SAIC Fixed bugs for ACVC 2.0.1. +-- +--! + +with Report; +with Ada.Strings.Bounded; +with Ada.Strings.Maps; + +procedure CXA4009 is + +begin + + Report.Test("CXA4009", "Check that the subprograms defined in " & + "package Ada.Strings.Bounded are available, " & + "and that they produce correct results, " & + "especially under conditions where " & + "truncation of the result is required"); + + Test_Block: + declare + + package AS renames Ada.Strings; + package ASB renames Ada.Strings.Bounded; + package Maps renames Ada.Strings.Maps; + + package B10 is new ASB.Generic_Bounded_Length(Max => 10); + use type B10.Bounded_String; + + Result_String : B10.Bounded_String; + Test_String : B10.Bounded_String; + AtoE_Bnd_Str : B10.Bounded_String := B10.To_Bounded_String("abcde"); + FtoJ_Bnd_Str : B10.Bounded_String := B10.To_Bounded_String("fghij"); + AtoJ_Bnd_Str : B10.Bounded_String := + B10.To_Bounded_String("abcdefghij"); + + Location : Natural := 0; + Total_Count : Natural := 0; + + CD_Set : Maps.Character_Set := Maps.To_Set("cd"); + XY_Set : Maps.Character_Set := Maps.To_Set("xy"); + + + begin + + -- Function Overwrite with Truncation + -- Drop = Error (Default). + + begin + Test_String := AtoJ_Bnd_Str; + Result_String := + B10.Overwrite(Source => Test_String, -- "abcdefghij" + Position => 9, + New_Item => "xyz", + Drop => AS.Error); + Report.Failed("Exception not raised by Function Overwrite"); + exception + when AS.Length_Error => null; -- Expected exception raised. + when others => + Report.Failed("Incorrect exception raised by Function Overwrite"); + end; + + -- Drop = Left + + Result_String := + B10.Overwrite(Source => Test_String, -- "abcdefghij" + Position => B10.Length(Test_String), -- 10 + New_Item => "xyz", + Drop => Ada.Strings.Left); + + if B10.To_String(Result_String) /= "cdefghixyz" then -- drop a,b + Report.Failed + ("Incorrect result from Function Overwrite, Drop = Left"); + end if; + + -- Drop = Right + + Result_String := B10.Overwrite(Test_String, -- "abcdefghij" + 3, + "xxxyyyzzz", + Ada.Strings.Right); + + if B10.To_String(Result_String) /= "abxxxyyyzz" then -- one 'z' dropped + Report.Failed + ("Incorrect result from Function Overwrite, Drop = Right"); + end if; + + -- Additional cases of function Overwrite. + + if B10.Overwrite(B10.To_Bounded_String("a"), -- Source length = 1 + 1, + " abc ") /= + B10.To_Bounded_String(" abc ") or + B10.Overwrite(B10.Null_Bounded_String, -- Null source + 1, + "abcdefghij") /= + AtoJ_Bnd_Str or + B10.Overwrite(AtoE_Bnd_Str, + B10.To_String(AtoE_Bnd_Str)'First, + " ") /= -- New_Item = 1 + B10.To_Bounded_String(" bcde") + then + Report.Failed("Incorrect result from Function Overwrite"); + end if; + + + + -- Procedure Overwrite + -- Correct usage, no truncation. + + Test_String := AtoE_Bnd_Str; -- "abcde" + B10.Overwrite(Test_String, 2, "xyz"); + + if Test_String /= B10.To_Bounded_String("axyze") then + Report.Failed("Incorrect result from Procedure Overwrite - 1"); + end if; + + Test_String := B10.To_Bounded_String("abc"); + B10.Overwrite(Test_String, 2, ""); -- New_Item is null string. + + if Test_String /= B10.To_Bounded_String("abc") then + Report.Failed("Incorrect result from Procedure Overwrite - 2"); + end if; + + -- Drop = Error (Default). + + begin + Test_String := AtoJ_Bnd_Str; + B10.Overwrite(Source => Test_String, -- "abcdefghij" + Position => 8, + New_Item => "uvwxyz"); + Report.Failed("Exception not raised by Procedure Overwrite"); + exception + when AS.Length_Error => null; -- Expected exception raised. + when others => + Report.Failed("Incorrect exception raised by Procedure Overwrite"); + end; + + -- Drop = Left + + Test_String := AtoJ_Bnd_Str; + B10.Overwrite(Source => Test_String, -- "abcdefghij" + Position => B10.Length(Test_String) - 2, -- 8 + New_Item => "uvwxyz", + Drop => Ada.Strings.Left); + + if B10.To_String(Test_String) /= "defguvwxyz" then -- drop a-c + Report.Failed + ("Incorrect result from Procedure Overwrite, Drop = Left"); + end if; + + -- Drop = Right + + Test_String := AtoJ_Bnd_Str; + B10.Overwrite(Test_String, -- "abcdefghij" + 3, + "xxxyyyzzz", + Ada.Strings.Right); + + if B10.To_String(Test_String) /= "abxxxyyyzz" then -- one 'z' dropped + Report.Failed + ("Incorrect result from Procedure Overwrite, Drop = Right"); + end if; + + + + -- Function Delete + + if B10.Delete(Source => AtoJ_Bnd_Str, -- "abcdefghij" + From => 3, + Through => 8) /= + B10."&"(B10.Head(AtoJ_Bnd_Str, 2), + B10.Tail(AtoJ_Bnd_Str, 2)) or + B10.Delete(AtoJ_Bnd_Str, 6, B10.Length(AtoJ_Bnd_Str)) /= + AtoE_Bnd_Str or + B10.Delete(AtoJ_Bnd_Str, 1, 5) /= + FtoJ_Bnd_Str or + B10.Delete(AtoE_Bnd_Str, 4, 5) /= + B10.Delete(AtoJ_Bnd_Str, 4, B10.Length(AtoJ_Bnd_Str)) + then + Report.Failed("Incorrect result from Function Delete - 1"); + end if; + + if B10.Delete(B10.To_Bounded_String("a"), 1, 1) /= + B10.Null_Bounded_String or + B10.Delete(AtoE_Bnd_Str, + 5, + B10.To_String(AtoE_Bnd_Str)'First) /= + AtoE_Bnd_Str or + B10.Delete(AtoE_Bnd_Str, + B10.To_String(AtoE_Bnd_Str)'Last, + B10.To_String(AtoE_Bnd_Str)'Last) /= + B10.To_Bounded_String("abcd") + then + Report.Failed("Incorrect result from Function Delete - 2"); + end if; + + + + -- Function Trim + + declare + + Text : B10.Bounded_String := B10.To_Bounded_String("Text"); + type Bnd_Array_Type is array (1..5) of B10.Bounded_String; + Bnd_Array : Bnd_Array_Type := + (B10.To_Bounded_String(" Text"), + B10.To_Bounded_String("Text "), + B10.To_Bounded_String(" Text "), + B10.To_Bounded_String("Text Text"), -- Ensure no inter-string + B10.To_Bounded_String(" Text Text")); -- trimming of blanks. + + begin + + for i in Bnd_Array_Type'Range loop + case i is + when 4 => + if B10.Trim(Bnd_Array(i), AS.Both) /= + Bnd_Array(i) then -- no change + Report.Failed("Incorrect result from Function Trim - 4"); + end if; + when 5 => + if B10.Trim(Bnd_Array(i), AS.Both) /= + B10."&"(Text, B10."&"(' ', Text)) then + Report.Failed("Incorrect result from Function Trim - 5"); + end if; + when others => + if B10.Trim(Bnd_Array(i), AS.Both) /= Text then + Report.Failed("Incorrect result from Function Trim - " & + Integer'Image(i)); + end if; + end case; + end loop; + + end; + + + + -- Function Trim using Sets + + -- Trim characters in sets from both sides of the bounded string. + if B10.Trim(Source => B10.To_Bounded_String("ddabbaxx"), + Left => CD_Set, + Right => XY_Set) /= + B10.To_Bounded_String("abba") + then + Report.Failed + ("Incorrect result from Fn Trim - Sets, Left & Right side - 1"); + end if; + + -- Ensure that the characters in the set provided as the actual to + -- parameter Right are not trimmed from the left side of the bounded + -- string; likewise for the opposite side. Only "cd" trimmed from left + -- side, and only "xy" trimmed from right side. + + if B10.Trim(B10.To_Bounded_String("cdxyabcdxy"), CD_Set, XY_Set) /= + B10.To_Bounded_String("xyabcd") + then + Report.Failed + ("Incorrect result from Fn Trim - Sets, Left & Right side - 2"); + end if; + + -- Ensure that characters contained in the sets are not trimmed from + -- the "interior" of the bounded string, just the appropriate ends. + + if B10.Trim(B10.To_Bounded_String("cdabdxabxy"), CD_Set, XY_Set) /= + B10.To_Bounded_String("abdxab") + then + Report.Failed + ("Incorrect result from Fn Trim - Sets, Left & Right side - 3"); + end if; + + -- Trim characters in set from right side only. No change to Left side. + + if B10.Trim(B10.To_Bounded_String("abxyzddcd"), XY_Set, CD_Set) /= + B10.To_Bounded_String("abxyz") + then + Report.Failed + ("Incorrect result from Fn Trim - Sets, Right side"); + end if; + + -- Trim no characters on either side of the bounded string. + + Result_String := B10.Trim(AtoJ_Bnd_Str, CD_Set, XY_Set); + if Result_String /= AtoJ_Bnd_Str then + Report.Failed("Incorrect result from Fn Trim - Sets, Neither side"); + end if; + + if B10.Trim(AtoE_Bnd_Str, Maps.Null_Set, Maps.Null_Set) /= + AtoE_Bnd_Str or + B10.Trim(B10.To_Bounded_String("dcddcxyyxx"), + CD_Set, + XY_Set) /= + B10.Null_Bounded_String + then + Report.Failed("Incorrect result from Function Trim"); + end if; + + + + -- Procedure Trim using Sets + + -- Trim characters in sets from both sides of the bounded string. + + Test_String := B10.To_Bounded_String("dcabbayx"); + B10.Trim(Source => Test_String, + Left => CD_Set, + Right => XY_Set); + + if Test_String /= B10.To_Bounded_String("abba") then + Report.Failed + ("Incorrect result from Proc Trim - Sets, Left & Right side - 1"); + end if; + + -- Ensure that the characters in the set provided as the actual to + -- parameter Right are not trimmed from the left side of the bounded + -- string; likewise for the opposite side. Only "cd" trimmed from left + -- side, and only "xy" trimmed from right side. + + Test_String := B10.To_Bounded_String("cdxyabcdxy"); + B10.Trim(Test_String, CD_Set, XY_Set); + + if Test_String /= B10.To_Bounded_String("xyabcd") then + Report.Failed + ("Incorrect result from Proc Trim - Sets, Left & Right side - 2"); + end if; + + -- Ensure that characters contained in the sets are not trimmed from + -- the "interior" of the bounded string, just the appropriate ends. + + Test_String := B10.To_Bounded_String("cdabdxabxy"); + B10.Trim(Test_String, CD_Set, XY_Set); + + if not (Test_String = B10.To_Bounded_String("abdxab")) then + Report.Failed + ("Incorrect result from Proc Trim - Sets, Left & Right side - 3"); + end if; + + -- Trim characters in set from Left side only. No change to Right side. + + Test_String := B10.To_Bounded_String("cccdabxyz"); + B10.Trim(Test_String, CD_Set, XY_Set); + + if Test_String /= B10.To_Bounded_String("abxyz") then + Report.Failed + ("Incorrect result from Proc Trim for Sets, Left side only"); + end if; + + -- Trim no characters on either side of the bounded string. + + Test_String := AtoJ_Bnd_Str; + B10.Trim(Test_String, CD_Set, CD_Set); + + if Test_String /= AtoJ_Bnd_Str then + Report.Failed("Incorrect result from Proc Trim-Sets, Neither side"); + end if; + + + + -- Function Head with Truncation + -- Drop = Error (Default). + + begin + Result_String := B10.Head(Source => AtoJ_Bnd_Str, -- max length + Count => B10.Length(AtoJ_Bnd_Str) + 1, + Pad => 'X'); + Report.Failed("Length_Error not raised by Function Head"); + exception + when AS.Length_Error => null; -- Expected exception raised. + when others => + Report.Failed("Incorrect exception raised by Function Head"); + end; + + -- Drop = Left + + -- Pad characters (5) are appended to the right end of the string + -- (which is initially at its maximum length), then the first five + -- characters of the intermediate result are dropped to conform to + -- the maximum size limit of the bounded string (10). + + Result_String := B10.Head(B10.To_Bounded_String("ABCDEFGHIJ"), + 15, + 'x', + Ada.Strings.Left); + + if Result_String /= B10.To_Bounded_String("FGHIJxxxxx") then + Report.Failed("Incorrect result from Function Head, Drop = Left"); + end if; + + -- Drop = Right + + -- Pad characters (6) are appended to the left end of the string + -- (which is initially at one less than its maximum length), then the + -- last five characters of the intermediate result are dropped + -- (which in this case are the pad characters) to conform to the + -- maximum size limit of the bounded string (10). + + Result_String := B10.Head(B10.To_Bounded_String("ABCDEFGHI"), + 15, + 'x', + Ada.Strings.Right); + + if Result_String /= B10.To_Bounded_String("ABCDEFGHIx") then + Report.Failed("Incorrect result from Function Head, Drop = Right"); + end if; + + -- Additional cases. + + if B10.Head(B10.Null_Bounded_String, 5) /= + B10.To_Bounded_String(" ") or + B10.Head(AtoE_Bnd_Str, + B10.Length(AtoE_Bnd_Str)) /= + AtoE_Bnd_Str + then + Report.Failed("Incorrect result from Function Head"); + end if; + + + + -- Function Tail with Truncation + -- Drop = Error (Default Case) + + begin + Result_String := B10.Tail(Source => AtoJ_Bnd_Str, -- max length + Count => B10.Length(AtoJ_Bnd_Str) + 1, + Pad => Ada.Strings.Space, + Drop => Ada.Strings.Error); + Report.Failed("Length_Error not raised by Function Tail"); + exception + when AS.Length_Error => null; -- Expected exception raised. + when others => + Report.Failed("Incorrect exception raised by Function Tail"); + end; + + -- Drop = Left + + -- Pad characters (5) are appended to the left end of the string + -- (which is initially at two less than its maximum length), then + -- the first three characters of the intermediate result (in this + -- case, 3 pad characters) are dropped. + + Result_String := B10.Tail(B10.To_Bounded_String("ABCDEFGH"), -- 8 ch + 13, + 'x', + Ada.Strings.Left); + + if Result_String /= B10.To_Bounded_String("xxABCDEFGH") then + Report.Failed("Incorrect result from Function Tail, Drop = Left"); + end if; + + -- Drop = Right + + -- Pad characters (3) are appended to the left end of the string + -- (which is initially at its maximum length), then the last three + -- characters of the intermediate result are dropped. + + Result_String := B10.Tail(B10.To_Bounded_String("ABCDEFGHIJ"), + 13, + 'x', + Ada.Strings.Right); + + if Result_String /= B10.To_Bounded_String("xxxABCDEFG") then + Report.Failed("Incorrect result from Function Tail, Drop = Right"); + end if; + + -- Additional cases. + + if B10.Tail(B10.Null_Bounded_String, 3, ' ') /= + B10.To_Bounded_String(" ") or + B10.Tail(AtoE_Bnd_Str, + B10.To_String(AtoE_Bnd_Str)'First) /= + B10.To_Bounded_String("e") + then + Report.Failed("Incorrect result from Function Tail"); + end if; + + + + -- Function Replicate (#, Char) with Truncation + -- Drop = Error (Default). + + begin + Result_String := B10.Replicate(Count => B10.Max_Length + 5, + Item => 'A', + Drop => AS.Error); + Report.Failed + ("Length_Error not raised by Replicate for characters"); + exception + when AS.Length_Error => null; -- Expected exception raised. + when others => + Report.Failed + ("Incorrect exception raised by Replicate for characters"); + end; + + -- Drop = Left, Right + -- Since this version of Replicate uses character parameters, the + -- result after truncation from left or right will appear the same. + -- The result will be a 10 character bounded string, composed of 10 + -- "Item" characters. + + if B10.Replicate(Count => 20, Item => 'A', Drop => Ada.Strings.Left) /= + B10.Replicate(15, 'A', Ada.Strings.Right) + then + Report.Failed("Incorrect result from Replicate for characters - 1"); + end if; + + -- Blank-filled 10 character bounded strings. + + if B10.Replicate(B10.Max_Length + 1, ' ', Drop => Ada.Strings.Left) /= + B10.Replicate(B10.Max_Length, Ada.Strings.Space) + then + Report.Failed("Incorrect result from Replicate for characters - 2"); + end if; + + -- Additional cases. + + if B10.Replicate(0, 'a') /= B10.Null_Bounded_String or + B10.Replicate(1, 'a') /= B10.To_Bounded_String("a") + then + Report.Failed("Incorrect result from Replicate for characters - 3"); + end if; + + + + -- Function Replicate (#, String) with Truncation + -- Drop = Error (Default). + + begin + Result_String := B10.Replicate(Count => 5, -- result would be 15. + Item => "abc"); + Report.Failed + ("Length_Error not raised by Replicate for strings"); + exception + when AS.Length_Error => null; -- Expected exception raised. + when others => + Report.Failed + ("Incorrect exception raised by Replicate for strings"); + end; + + -- Drop = Left + + Result_String := B10.Replicate(3, "abcd", Drop => Ada.Strings.Left); + + if Result_String /= B10.To_Bounded_String("cdabcdabcd") then + Report.Failed + ("Incorrect result from Replicate for strings, Drop = Left"); + end if; + + -- Drop = Right + + Result_String := B10.Replicate(3, "abcd", Drop => Ada.Strings.Right); + + if Result_String /= B10.To_Bounded_String("abcdabcdab") then + Report.Failed + ("Incorrect result from Replicate for strings, Drop = Right"); + end if; + + -- Additional cases. + + if B10.Replicate(10, "X") /= B10.To_Bounded_String("XXXXXXXXXX") or + B10.Replicate(10, "") /= B10.Null_Bounded_String or + B10.Replicate( 0, "ab") /= B10.Null_Bounded_String + then + Report.Failed("Incorrect result from Replicate for strings"); + end if; + + + exception + when others => Report.Failed("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + +end CXA4009; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4010.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4010.a new file mode 100644 index 000000000..8646b12b5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4010.a @@ -0,0 +1,275 @@ +-- CXA4010.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 subprograms defined in package Ada.Strings.Unbounded +-- are available, and that they produce correct results. Specifically, +-- check the subprograms To_String, To_Unbounded_String, Insert, "&", +-- "*", Length, Slice, Replace_Slice, Overwrite, Index, Index_Non_Blank, +-- Head, Tail, and "=", "<=", ">=". +-- +-- TEST DESCRIPTION: +-- This test demonstrates the uses of many of the subprograms defined +-- in package Ada.Strings.Unbounded for use with unbounded strings. +-- The test simulates how unbounded strings could be used +-- to simulate paragraphs of text. Modifications could be easily be +-- performed using the provided subprograms (although in this test, the +-- main modification performed was the addition of more text to the +-- string). One would not have to worry about the formatting of the +-- paragraph until it was finished and correct in content. Then, once +-- all required editing is complete, the unbounded strings can be divided +-- up into the appropriate lengths based on particular formatting +-- requirements. The test then compares the formatted text product +-- with a predefined "finished product". +-- +-- This test uses a large number of the subprograms provided +-- by package Ada.Strings.Unbounded. Often, the processing involved +-- could have been performed more efficiently using a minimum number +-- of the subprograms, in conjunction with loops, etc. However, for +-- testing purposes, and in the interest of minimizing the number of +-- tests developed, subprogram variety and feature mixing was stressed. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +with Report; +with Ada.Strings.Maps; +with Ada.Strings.Unbounded; + +procedure CXA4010 is +begin + + Report.Test ("CXA4010", "Check that the subprograms defined in " & + "package Ada.Strings.Unbounded are available, " & + "and that they produce correct results"); + + Test_Block: + declare + + package ASUnb renames Ada.Strings.Unbounded; + use type ASUnb.Unbounded_String; + use Ada.Strings; + + Pamphlet_Paragraph_Count : constant := 2; + Lines : constant := 4; + Line_Length : constant := 40; + + type Document_Type is array (Positive range <>) + of ASUnb.Unbounded_String; + + type Camera_Ready_Copy_Type is array (1..Lines) + of String (1..Line_Length); + + Pamphlet : Document_Type (1..Pamphlet_Paragraph_Count); + + Camera_Ready_Copy : Camera_Ready_Copy_Type := + (others => (others => Ada.Strings.Space)); + + TC_Finished_Product : Camera_Ready_Copy_Type := + ( 1 => "Ada is a programming language designed ", + 2 => "to support long-lived, reliable software", + 3 => " systems. ", + 4 => "Go with Ada! "); + + ----- + + + procedure Enter_Text_Into_Document (Document : in out Document_Type) is + begin + + -- Fill in both "paragraphs" of the document. Each unbounded string + -- functions as an individual paragraph, containing an unspecified + -- number of characters. + -- Use a variety of different unbounded string subprograms to load + -- the data. + + Document(1) := ASUnb.To_Unbounded_String("Ada is a language"); + + -- Insert the word "programming" prior to "language". + Document(1) := + ASUnb.Insert(Document(1), + ASUnb.Index(Document(1), + "language"), + ASUnb.To_String("progra" & -- Str & + ASUnb."*"(2,'m') & -- Unbd & + "ing ")); -- Str + + + -- Overwrite the word "language" with "language" + additional text. + Document(1) := + ASUnb.Overwrite(Document(1), + ASUnb.Index(Document(1), + ASUnb.To_String( + ASUnb.Tail(Document(1), 8, ' ')), + Ada.Strings.Backward), + "language designed to support long-lifed"); + + + -- Replace the word "lifed" with "lived". + Document(1) := + ASUnb.Replace_Slice(Document(1), + ASUnb.Index(Document(1), "lifed"), + ASUnb.Length(Document(1)), + "lived"); + + + -- Overwrite the word "lived" with "lived" + additional text. + Document(1) := + ASUnb.Overwrite(Document(1), + ASUnb.Index(Document(1), + ASUnb.To_String( + ASUnb.Tail(Document(1), 5, ' ')), + Ada.Strings.Backward), + "lived, reliable software systems."); + + + -- Use several of the overloaded versions of "&" to form this + -- unbounded string. + + Document(2) := 'G' & + ASUnb.To_Unbounded_String("o ") & + ASUnb.To_Unbounded_String("with") & + ' ' & + "Ada!"; + + end Enter_Text_Into_Document; + + + ----- + + + procedure Create_Camera_Ready_Copy + (Document : in Document_Type; + Camera_Copy : out Camera_Ready_Copy_Type) is + begin + -- Break the unbounded strings into fixed lengths. + + -- Search the first unbounded string for portions of text that + -- are less than or equal to the length of a string in the + -- Camera_Ready_Copy_Type object. + + Camera_Copy(1) := -- Take characters 1-39, + ASUnb.Slice(Document(1), -- and append a blank space. + 1, + ASUnb.Index(ASUnb.To_Unbounded_String( + ASUnb.Slice(Document(1), + 1, + Line_Length)), + Ada.Strings.Maps.To_Set(' '), + Ada.Strings.Inside, + Ada.Strings.Backward)) & ' '; + + Camera_Copy(2) := -- Take characters 40-79. + ASUnb.Slice(Document(1), + 40, + (ASUnb.Index_Non_Blank -- Should return 79 + (ASUnb.To_Unbounded_String + (ASUnb.Slice(Document(1), -- Slice (40..79) + 40, + 79)), + Ada.Strings.Backward) + 39)); -- Increment since + -- this slice starts + -- at 40. + + Camera_Copy(3)(1..9) := ASUnb.Slice(Document(1), -- Characters 80-88 + 80, + ASUnb.Length(Document(1))); + + + -- Break the second unbounded string into the appropriate length. + -- It is only twelve characters in length, so the entire unbounded + -- string will be placed on one string of the output object. + + Camera_Copy(4)(1..ASUnb.Length(Document(2))) := + ASUnb.To_String(ASUnb.Head(Document(2), + ASUnb.Length(Document(2)))); + + end Create_Camera_Ready_Copy; + + + ----- + + + function Valid_Proofread (Draft, Master : Camera_Ready_Copy_Type) + return Boolean is + begin + + -- Evaluate strings for equality, using the operators defined in + -- package Ada.Strings.Unbounded. The less than/greater than or + -- equal comparisons should evaluate to "equals => True". + + if ASUnb.To_Unbounded_String(Draft(1)) = -- "="(Unb,Unb) + ASUnb.To_Unbounded_String(Master(1)) and + ASUnb.To_Unbounded_String(Draft(2)) <= -- "<="(Unb,Unb) + ASUnb.To_Unbounded_String(Master(2)) and + ASUnb.To_Unbounded_String(Draft(3)) >= -- ">="(Unb,Unb) + ASUnb.To_Unbounded_String(Master(3)) and + ASUnb.To_Unbounded_String(Draft(4)) = -- "="(Unb,Unb) + ASUnb.To_Unbounded_String(Master(4)) + then + return True; + else + return False; + end if; + + end Valid_Proofread; + + + ----- + + + begin + + -- Enter text into the unbounded string paragraphs of the document. + + Enter_Text_Into_Document (Pamphlet); + + + -- Reformat the unbounded strings into fixed string format. + + Create_Camera_Ready_Copy (Document => Pamphlet, + Camera_Copy => Camera_Ready_Copy); + + + -- Verify the conversion process. + + if not Valid_Proofread (Draft => Camera_Ready_Copy, + Master => TC_Finished_Product) + then + Report.Failed ("Incorrect string processing result"); + end if; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + + Report.Result; + +end CXA4010; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4011.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4011.a new file mode 100644 index 000000000..05388a04b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4011.a @@ -0,0 +1,376 @@ +-- CXA4011.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 subprograms defined in package Ada.Strings.Unbounded +-- are available, and that they produce correct results. Specifically, +-- check the subprograms To_Unbounded_String, "&", ">", "<", Element, +-- Replace_Element, Count, Find_Token, Translate, Trim, Delete, and +-- "*". +-- +-- TEST DESCRIPTION: +-- This test demonstrates the uses of many of the subprograms defined +-- in package Ada.Strings.Unbounded for use with unbounded strings. +-- The test simulates how unbounded strings could be processed in a +-- user environment, using the subprograms provided in this package. +-- +-- This test uses a variety of the subprograms defined in the unbounded +-- string package in ways typical of common usage, with different +-- combinations of available subprograms being used to accomplish +-- similar unbounded string processing goals. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 27 Feb 95 SAIC Test description modification. +-- 01 Nov 95 SAIC Update and repair for ACVC 2.0.1. +-- +--! + +with Report; +with Ada.Strings.Maps; +with Ada.Strings.Unbounded; + +procedure CXA4011 is +begin + + Report.Test ("CXA4011", "Check that the subprograms defined in " & + "package Ada.Strings.Unbounded are available, " & + "and that they produce correct results"); + + Test_Block: + declare + + package ASUnb renames Ada.Strings.Unbounded; + use Ada.Strings; + use type Maps.Character_Set; + use type ASUnb.Unbounded_String; + + Cad_String : ASUnb.Unbounded_String := + ASUnb.To_Unbounded_String("cad"); + + Complete_String : ASUnb.Unbounded_String := + ASUnb.To_Unbounded_String("Incomplete") & + Ada.Strings.Space & + ASUnb.To_Unbounded_String("String"); + + Incomplete_String : ASUnb.Unbounded_String := + ASUnb.To_Unbounded_String("ncomplete Strin"); + + Incorrect_Spelling : ASUnb.Unbounded_String := + ASUnb.To_Unbounded_String("Guob Dai"); + + Magic_String : ASUnb.Unbounded_String := + ASUnb.To_Unbounded_String("abracadabra"); + + Incantation : ASUnb.Unbounded_String := Magic_String; + + + A_Small_G : Character := 'g'; + A_Small_D : Character := 'd'; + + ABCD_Set : Maps.Character_Set := Maps.To_Set("abcd"); + B_Set : Maps.Character_Set := Maps.To_Set('b'); + AB_Set : Maps.Character_Set := Maps."OR"(Maps.To_Set('a'), B_Set); + + Code_Map : Maps.Character_Mapping := + Maps.To_Mapping(From => "abcd", To => "wxyz"); + Reverse_Code_Map : Maps.Character_Mapping := + Maps.To_Mapping(From => "wxyz", To => "abcd"); + Non_Existent_Map : Maps.Character_Mapping := + Maps.To_Mapping(From => "jkl", To => "mno"); + + + Token_Start : Positive; + Token_End : Natural := 0; + Matching_Letters : Natural := 0; + + + begin + + -- "&" + + -- Prepend an 'I' and append a 'g' to the string. + Incomplete_String := ASUnb."&"('I', Incomplete_String); -- Char & Unb + Incomplete_String := ASUnb."&"(Incomplete_String, + A_Small_G); -- Unb & Char + + if Incomplete_String < Complete_String or + Incomplete_String > Complete_String or + Incomplete_String /= Complete_String + then + Report.Failed("Incorrect result from use of ""&"" operator"); + end if; + + + -- Element + + -- Last element of the unbounded string should be a 'g'. + if ASUnb.Element(Incomplete_String, ASUnb.Length(Incomplete_String)) /= + A_Small_G + then + Report.Failed("Incorrect result from use of Function Element - 1"); + end if; + + if ASUnb.Element(Incomplete_String, 2) /= + ASUnb.Element(ASUnb.Tail(Incomplete_String, 2), 1) or + ASUnb.Element(ASUnb.Head(Incomplete_String, 4), 2) /= + ASUnb.Element(ASUnb.To_Unbounded_String("wnqz"), 2) + then + Report.Failed("Incorrect result from use of Function Element - 2"); + end if; + + + -- Replace_Element + + -- The unbounded string Incorrect_Spelling starts as "Guob Dai", and + -- is transformed by the following three procedure calls to "Good Day". + + ASUnb.Replace_Element(Incorrect_Spelling, 2, 'o'); + + ASUnb.Replace_Element(Incorrect_Spelling, + ASUnb.Index(Incorrect_Spelling, B_Set), + A_Small_D); + + ASUnb.Replace_Element(Source => Incorrect_Spelling, + Index => ASUnb.Length(Incorrect_Spelling), + By => 'y'); + + if Incorrect_Spelling /= ASUnb.To_Unbounded_String("Good Day") then + Report.Failed("Incorrect result from Procedure Replace_Element"); + end if; + + + -- Count + + -- Determine the number of characters in the unbounded string that + -- are contained in the set. + + Matching_Letters := ASUnb.Count(Source => Magic_String, + Set => ABCD_Set); + + if Matching_Letters /= 9 then + Report.Failed + ("Incorrect result from Function Count with Set parameter"); + end if; + + -- Determine the number of occurrences of the following pattern strings + -- in the unbounded string Magic_String. + + if ASUnb.Count(Magic_String, "ab") /= + (ASUnb.Count(Magic_String, "ac") + ASUnb.Count(Magic_String, "ad")) or + ASUnb.Count(Magic_String, "ab") /= 2 + then + Report.Failed + ("Incorrect result from Function Count with String parameter"); + end if; + + + -- Find_Token + + ASUnb.Find_Token(Magic_String, -- Find location of first "ab". + AB_Set, -- Should be (1..2). + Ada.Strings.Inside, + Token_Start, + Token_End); + + if Natural(Token_Start) /= ASUnb.To_String(Magic_String)'First or + Token_End /= ASUnb.Index(Magic_String, B_Set) + then + Report.Failed("Incorrect result from Procedure Find_Token - 1"); + end if; + + + ASUnb.Find_Token(Source => Magic_String, -- Find location of char 'r' + Set => ABCD_Set, -- in string, should be (3..3) + Test => Ada.Strings.Outside, + First => Token_Start, + Last => Token_End); + + if Natural(Token_Start) /= 3 or + Token_End /= 3 then + Report.Failed("Incorrect result from Procedure Find_Token - 2"); + end if; + + + ASUnb.Find_Token(Magic_String, -- No 'g' is in the string, so + Maps.To_Set(A_Small_G), -- the result parameters should + Ada.Strings.Inside, -- be First = Source'First and + First => Token_Start, -- Last = 0. + Last => Token_End); + + if Token_Start /= ASUnb.To_String(Magic_String)'First or + Token_End /= 0 + then + Report.Failed("Incorrect result from Procedure Find_Token - 3"); + end if; + + + -- Translate + + -- Use a mapping ("abcd" -> "wxyz") to transform the contents of + -- the unbounded string. + -- Magic_String = "abracadabra" + + Incantation := ASUnb.Translate(Magic_String, Code_Map); + + if Incantation /= ASUnb.To_Unbounded_String("wxrwywzwxrw") then + Report.Failed("Incorrect result from Function Translate"); + end if; + + -- Use the inverse mapping of the one above to return the "translated" + -- unbounded string to its original form. + + ASUnb.Translate(Incantation, Reverse_Code_Map); + + -- The map contained in the following call to Translate contains one + -- element, and this element is not found in the unbounded string, so + -- this call to Translate should have no effect on the unbounded string. + + if Incantation /= ASUnb.Translate(Magic_String, Non_Existent_Map) then + Report.Failed("Incorrect result from Procedure Translate"); + end if; + + + -- Trim + + Trim_Block: + declare + + XYZ_Set : Maps.Character_Set := Maps.To_Set("xyz"); + PQR_Set : Maps.Character_Set := Maps.To_Set("pqr"); + + Pad : constant ASUnb.Unbounded_String := + ASUnb.To_Unbounded_String("Pad"); + + The_New_Ada : constant ASUnb.Unbounded_String := + ASUnb.To_Unbounded_String("Ada9X"); + + Space_Array : array (1..4) of ASUnb.Unbounded_String := + (ASUnb.To_Unbounded_String(" Pad "), + ASUnb.To_Unbounded_String("Pad "), + ASUnb.To_Unbounded_String(" Pad"), + Pad); + + String_Array : array (1..5) of ASUnb.Unbounded_String := + (ASUnb.To_Unbounded_String("xyzxAda9Xpqr"), + ASUnb.To_Unbounded_String("Ada9Xqqrp"), + ASUnb.To_Unbounded_String("zxyxAda9Xqpqr"), + ASUnb.To_Unbounded_String("xxxyAda9X"), + The_New_Ada); + + begin + + -- Examine the version of Trim that removes blanks from + -- the left and/or right of a string. + + for i in 1..4 loop + if ASUnb.Trim(Space_Array(i), Ada.Strings.Both) /= Pad then + Report.Failed("Incorrect result from Trim for spaces - " & + Integer'Image(i)); + end if; + end loop; + + -- Examine the version of Trim that removes set characters from + -- the left and right of a string. + + for i in 1..5 loop + if ASUnb.Trim(String_Array(i), + Left => XYZ_Set, + Right => PQR_Set) /= The_New_Ada then + Report.Failed + ("Incorrect result from Trim for set characters - " & + Integer'Image(i)); + end if; + end loop; + + end Trim_Block; + + + -- Delete + + -- Use the Delete function to remove the first four and last four + -- characters from the string. + + if ASUnb.Delete(Source => ASUnb.Delete(Magic_String, + 8, + ASUnb.Length(Magic_String)), + From => ASUnb.To_String(Magic_String)'First, + Through => 4) /= + Cad_String + then + Report.Failed("Incorrect results from Function Delete"); + end if; + + + -- Constructors ("*") + + Constructor_Block: + declare + + SOS : ASUnb.Unbounded_String; + + Dot : constant ASUnb.Unbounded_String := + ASUnb.To_Unbounded_String("Dot_"); + Dash : constant String := "Dash_"; + + Distress : ASUnb.Unbounded_String := + ASUnb.To_Unbounded_String("Dot_Dot_Dot_") & + ASUnb.To_Unbounded_String("Dash_Dash_Dash_") & + ASUnb.To_Unbounded_String("Dot_Dot_Dot"); + + Repeat : constant Natural := 3; + Separator : constant Character := '_'; + + Separator_Set : Maps.Character_Set := Maps.To_Set(Separator); + + begin + + -- Use the following constructor forms to construct the string + -- "Dot_Dot_Dot_Dash_Dash_Dash_Dot_Dot_Dot". Note that the + -- trailing underscore in the string is removed in the call to + -- Trim in the If statement condition. + + SOS := ASUnb."*"(Repeat, Dot); -- "*"(#, Unb Str) + + SOS := SOS & + ASUnb."*"(Repeat, Dash) & -- "*"(#, Str) + ASUnb."*"(Repeat, Dot); -- "*"(#, Unb Str) + + if ASUnb.Trim(SOS, Maps.Null_Set, Separator_Set) /= Distress then + Report.Failed("Incorrect results from Function ""*"""); + end if; + + end Constructor_Block; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + + Report.Result; + +end CXA4011; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4012.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4012.a new file mode 100644 index 000000000..5ab12b6df --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4012.a @@ -0,0 +1,305 @@ +-- CXA4012.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 types, operations, and other entities defined within +-- the package Ada.Strings.Wide_Maps are available and produce correct +-- results. +-- +-- TEST DESCRIPTION: +-- This test demonstrates the availability and function of the types and +-- operations defined in package Ada.Strings.Wide_Maps. It demonstrates +-- the use of these types and functions as they would be used in common +-- programming practice. +-- Wide_Character set creation, assignment, and comparison are evaluated +-- in this test. Each of the functions provided in package +-- Ada.Strings.Wide_Maps is utilized in creating or manipulating set +-- objects, and the function results are evaluated for correctness. +-- Wide_Character sequences are examined using the functions provided for +-- manipulating objects of this type. Likewise, Wide_Character maps are +-- created, and their contents evaluated. Exception raising conditions +-- from the function To_Mapping are also created. +-- Note: Throughout this test, the set logical operators are printed in +-- capital letters to enhance their visibility. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 01 Nov 95 SAIC Update and repair for ACVC 2.0.1. +-- +--! + +with Ada.Characters.Handling; +with Ada.Strings.Wide_Maps; + +package CXA40120 is + + function Equiv (Ch : Character) return Wide_Character; + function Equiv (Str : String) + return Ada.Strings.Wide_Maps.Wide_Character_Sequence; + function X_Map(From : Wide_Character) return Wide_Character; + +end CXA40120; + +package body CXA40120 is + + -- The following two functions are used to translate character and string + -- values to "Wide" values. They will be applied to certain Wide_Map + -- subprogram parameters to simulate the use of Wide_Characters and + -- Wide_Character_Sequences in actual practice. + -- Note: These functions do not actually return "equivalent" wide + -- characters to their character inputs, just "non-character" + -- wide characters. + + function Equiv (Ch : Character) return Wide_Character is + C : Character := Ch; + begin + if Ch = ' ' then + return Ada.Characters.Handling.To_Wide_Character(C); + else + return Wide_Character'Val(Character'Pos(Ch) + + Character'Pos(Character'Last) + 1); + end if; + end Equiv; + + function Equiv (Str : String) + return Ada.Strings.Wide_Maps.Wide_Character_Sequence is + use Ada.Strings; + WS : Wide_Maps.Wide_Character_Sequence(Str'First..Str'Last); + begin + for i in Str'First..Str'Last loop + WS(i) := Equiv(Str(i)); + end loop; + return WS; + end Equiv; + + function X_Map(From : Wide_Character) return Wide_Character is + begin + return Equiv('X'); + end X_Map; + +end CXA40120; + + + +with CXA40120; +with Ada.Characters.Handling; +with Ada.Strings.Wide_Maps; +with Report; + +procedure CXA4012 is + + use CXA40120; + use Ada.Strings; + +begin + + Report.Test ("CXA4012", "Check that the types, operations, and other " & + "entities defined within the package " & + "Ada.Strings.Wide_Maps are available and " & + "produce correct results"); + + Test_Block: + declare + + use type Wide_Maps.Wide_Character_Set; + + MidPoint_Letter : constant := 13; + Last_Letter : constant := 26; + + Vowels : constant Wide_Maps.Wide_Character_Sequence := + Equiv("aeiou"); + Quasi_Vowel : constant Wide_Character := Equiv('y'); + + Alphabet : Wide_Maps.Wide_Character_Sequence(1..Last_Letter); + Half_Alphabet : Wide_Maps.Wide_Character_Sequence(1..MidPoint_Letter); + Inverse_Alphabet : Wide_Maps.Wide_Character_Sequence(1..Last_Letter); + + Alphabet_Set, + Consonant_Set, + Vowel_Set, + Full_Vowel_Set, + First_Half_Set, + Second_Half_Set : Wide_Maps.Wide_Character_Set := Wide_Maps.Null_Set; + + begin + + -- Load the alphabet string for use in creating sets. + + for i in 0..MidPoint_Letter-1 loop + Half_Alphabet(i+1) := + Wide_Character'Val(Wide_Character'Pos(Equiv('a')) + i); + end loop; + + for i in 0..Last_Letter-1 loop + Alphabet(i+1) := + Wide_Character'Val(Wide_Character'Pos(Equiv('a')) + i); + end loop; + + + -- Initialize a series of Wide_Character_Set objects. + + Alphabet_Set := Wide_Maps.To_Set(Alphabet); + Vowel_Set := Wide_Maps.To_Set(Vowels); + Full_Vowel_Set := Vowel_Set OR Wide_Maps.To_Set(Quasi_Vowel); + Consonant_Set := Vowel_Set XOR Alphabet_Set; + + First_Half_Set := Wide_Maps.To_Set(Half_Alphabet); + Second_Half_Set := Alphabet_Set XOR First_Half_Set; + + + -- Evaluation of Set objects, operators, and functions. + + if Alphabet_Set /= (Vowel_Set OR Consonant_Set) then + Report.Failed("Incorrect set combinations using OR operator"); + end if; + + + for i in Vowels'First .. Vowels'Last loop + if not Wide_Maps.Is_In(Vowels(i), Vowel_Set) or + not Wide_Maps.Is_In(Vowels(i), Alphabet_Set) or + Wide_Maps.Is_In(Vowels(i), Consonant_Set) + then + Report.Failed("Incorrect function Is_In use with set " & + "combinations - " & Integer'Image(i)); + end if; + end loop; + + + if Wide_Maps.Is_Subset(Vowel_Set, First_Half_Set) or + Wide_Maps."<="(Vowel_Set, Second_Half_Set) or + not Wide_Maps.Is_Subset(Vowel_Set, Alphabet_Set) + then + Report.Failed + ("Incorrect set evaluation using Is_Subset function"); + end if; + + + if not (Full_Vowel_Set = Wide_Maps.To_Set(Equiv("aeiouy"))) then + Report.Failed("Incorrect result for ""="" set operator"); + end if; + + + if not ((Vowel_Set AND First_Half_Set) OR + (Full_Vowel_Set AND Second_Half_Set)) = Full_Vowel_Set then + Report.Failed + ("Incorrect result for AND, OR, or ""="" set operators"); + end if; + + + if (Alphabet_Set AND Wide_Maps.Null_Set) /= Wide_Maps.Null_Set or + (Alphabet_Set OR Wide_Maps.Null_Set) /= Alphabet_Set + then + Report.Failed("Incorrect result for AND or OR set operators"); + end if; + + + Vowel_Set := Full_Vowel_Set; + Vowel_Set := Vowel_Set AND (NOT Wide_Maps.To_Set(Quasi_Vowel)); + + if not (Vowels = Wide_Maps.To_Sequence(Vowel_Set)) then + Report.Failed("Incorrect Set to Sequence translation"); + end if; + + + for i in 0..Last_Letter-1 loop + Inverse_Alphabet(i+1) := Alphabet(Last_Letter-i); + end loop; + + + -- Wide_Character_Mapping + + declare + Inverse_Map : Wide_Maps.Wide_Character_Mapping := + Wide_Maps.To_Mapping(Alphabet, Inverse_Alphabet); + begin + if Wide_Maps.Value(Wide_Maps.Identity, Equiv('b')) /= + Wide_Maps.Value(Inverse_Map, Equiv('y')) + then + Report.Failed("Incorrect Inverse mapping"); + end if; + end; + + + -- Check that Translation_Error is raised when a character is + -- repeated in the parameter "From" string. + declare + Bad_Map : Wide_Maps.Wide_Character_Mapping; + begin + Bad_Map := Wide_Maps.To_Mapping(From => Equiv("aa"), + To => Equiv("yz")); + Report.Failed("Exception not raised with repeated character"); + exception + when Translation_Error => null; -- OK + when others => + Report.Failed("Incorrect exception raised in To_Mapping with " & + "a repeated character"); + end; + + + -- Check that Translation_Error is raised when the parameters of the + -- function To_Mapping are of unequal lengths. + declare + Bad_Map : Wide_Maps.Wide_Character_Mapping; + begin + Bad_Map := Wide_Maps.To_Mapping(Equiv("abc"), Equiv("yz")); + Report.Failed + ("Exception not raised with unequal parameter lengths"); + exception + when Translation_Error => null; -- OK + when others => + Report.Failed("Incorrect exception raised in To_Mapping with " & + "unequal parameter lengths"); + end; + + + -- Check that the access-to-subprogram type is defined and available. + -- This provides for one Wide_Character mapping capability only. + -- The actual mapping functionality will be tested in conjunction with + -- the tests of subprograms defined for Wide_String handling. + + declare + + X_Map_Ptr : Wide_Maps.Wide_Character_Mapping_Function := + X_Map'Access; + + begin + if X_Map_Ptr(Equiv('A')) /= -- both return 'X' + X_Map_Ptr.all(Equiv('Q')) + then + Report.Failed + ("Incorrect result using access-to-subprogram values"); + end if; + end; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + + Report.Result; + +end CXA4012; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4013.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4013.a new file mode 100644 index 000000000..0f93e9dc8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4013.a @@ -0,0 +1,203 @@ +-- CXA4013.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 subprograms defined in package Ada.Strings.Wide_Fixed +-- are available, and that they produce correct results. Specifically, +-- check the subprograms Index, "*" (Wide_String constructor function), +-- Count, Trim, and Replace_Slice. +-- +-- TEST DESCRIPTION: +-- This test demonstrates how certain Wide_Fixed string functions +-- are used to eliminate specific substrings from portions of text. +-- A procedure is defined that will take as parameters a source +-- Wide_String along with a substring that is to be completely removed +-- from the source string. The source Wide_String is parsed using the +-- Index function, and any substring slices are replaced in the source +-- Wide_String by a series of X's (based on the length of the substring.) +-- Three lines of text are provided to this procedure, and the resulting +-- substitutions are compared with expected results to validate the +-- string processing. +-- A global accumulator is updated with the number of occurrences of the +-- substring in the source string. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +with Ada.Strings; +with Ada.Strings.Wide_Fixed; +with Ada.Strings.Wide_Maps; +with Report; + +procedure CXA4013 is + +begin + + Report.Test ("CXA4013", "Check that the subprograms defined in package " & + "Ada.Strings.Wide_Fixed are available, and that " & + "they produce correct results"); + + Test_Block: + declare + + TC_Total : Natural := 0; + Number_Of_Lines : constant := 3; + WC : Wide_Character := + Wide_Character'Val(Character'Pos('X') + + Character'Pos(Character'Last) + + 1 ); + + subtype WS is Wide_String (1..25); + + type Restricted_Words_Array_Type is + array (1..10) of Wide_String (1..10); + + Restricted_Words : Restricted_Words_Array_Type := + (" platoon", " marines ", " Marines ", + "north ", "south ", " east", + " beach ", " airport", "airfield ", + " road "); + + type Page_Of_Text_Type is array (1..Number_Of_Lines) of WS; + + Text_Page : Page_Of_Text_Type := ("The platoon of Marines ", + "moved south on the south ", + "road to the airfield. "); + + TC_Revised_Line_1 : constant Wide_String := "The XXXXXXX of XXXXXXX "; + TC_Revised_Line_2 : constant Wide_String := "moved XXXXX on the XXXXX "; + TC_Revised_Line_3 : constant Wide_String := "XXXX to the XXXXXXXX. "; + + + function Equivalent (Left : WS; Right : Wide_String) + return Boolean is + begin + for i in WS'range loop + if Left(i) /= Right(i) then + if Left(i) /= WC or Right(i) /= 'X' then + return False; + end if; + end if; + end loop; + return True; + end Equivalent; + + --- + + procedure Censor (Source_String : in out Wide_String; + Pattern_String : in Wide_String) is + + use Ada.Strings.Wide_Fixed; -- allows infix notation of "*" below. + + -- Create a replacement string that is the same length as the + -- pattern string being removed. Use the infix notation of the + -- wide string constructor function. + + Replacement : constant Wide_String := + Pattern_String'Length * WC; -- "*" + + Going : Ada.Strings.Direction := Ada.Strings.Forward; + Start_Pos, + Index : Natural := Source_String'First; + + begin -- Censor + + -- Accumulate count of total replacement operations. + + TC_Total := TC_Total + + Ada.Strings.Wide_Fixed.Count -- Count + (Source => Source_String, + Pattern => Pattern_String, + Mapping => Ada.Strings.Wide_Maps.Identity); + loop + + Index := Ada.Strings.Wide_Fixed.Index -- Index + (Source_String(Start_Pos..Source_String'Last), + Pattern_String, + Going, + Ada.Strings.Wide_Maps.Identity); + + exit when Index = 0; -- No matches, exit loop. + + -- if a match was found, modify the substring. + Ada.Strings.Wide_Fixed.Replace_Slice -- Replace_Slice + (Source_String, + Index, + Index + Pattern_String'Length - 1, + Replacement); + Start_Pos := Index + Pattern_String'Length; + + end loop; + + end Censor; + + + begin + + -- Invoke Censor subprogram to cleanse text. + -- Loop through each line of text, and check for the presence of each + -- restricted word. + -- Use the Trim function to eliminate leading or trailing blanks from + -- the restricted word parameters. + + for Line in 1..Number_Of_Lines loop + for Word in Restricted_Words'Range loop + Censor (Text_Page(Line), -- Trim + Ada.Strings.Wide_Fixed.Trim(Restricted_Words(Word), + Ada.Strings.Both)); + end loop; + end loop; + + + -- Validate results. + + if TC_Total /= 6 then + Report.Failed ("Incorrect number of substitutions performed"); + end if; + + if not Equivalent (Text_Page(1), TC_Revised_Line_1) then + Report.Failed ("Incorrect substitutions on Line 1"); + end if; + + if not Equivalent (Text_Page(2), TC_Revised_Line_2) then + Report.Failed ("Incorrect substitutions on Line 2"); + end if; + + if not Equivalent (Text_Page(3), TC_Revised_Line_3) then + Report.Failed ("Incorrect substitutions on Line 3"); + end if; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + + Report.Result; + +end CXA4013; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4014.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4014.a new file mode 100644 index 000000000..6e26a0330 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4014.a @@ -0,0 +1,359 @@ +-- CXA4014.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 subprograms defined in package Ada.Strings.Wide_Fixed +-- are available, and that they produce correct results. Specifically, +-- check the subprograms Find_Token, Head, Index, Index_Non_Blank, Move, +-- Overwrite, and Replace_Slice, Tail, and Translate. +-- Use the access-to-subprogram mapping version of Translate (function +-- and procedure). +-- +-- TEST DESCRIPTION: +-- This test demonstrates how certain wide fixed string operations could +-- be used in wide string information processing. A procedure is defined +-- that will extract portions of a 50 character string that correspond to +-- certain data items (i.e., name, address, state, zip code). These +-- parsed items will then be added to the appropriate fields of data +-- base elements. These data base elements are then compared for +-- accuracy against a similar set of predefined data base +-- elements. +-- A variety of wide fixed string processing subprograms are used in this +-- test. Each parsing operation attempts to use a different combination +-- of the available subprograms to accomplish the same goal, therefore +-- continuity of approach to wide string parsing is not seen in this +-- test. +-- However, a wide variety of possible approaches are demonstrated, while +-- exercising a large number of the total predefined subprograms of +-- package Ada.Strings.Wide_Fixed. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 02 Nov 95 SAIC Update and repair for ACVC 2.0.1. +-- +--! + +package CXA40140 is + + UnderScore : Wide_Character := '_'; + Blank : Wide_Character := ' '; + + -- Function providing a mapping to a blank Wide_Character. + function US_to_Blank_Map (From : Wide_Character) return Wide_Character; + +end CXA40140; + +package body CXA40140 is + + function US_to_Blank_Map (From : Wide_Character) return Wide_Character is + begin + if From = UnderScore then + return Blank; + else + return From; + end if; + end US_to_Blank_Map; + +end CXA40140; + + +with CXA40140; +with Ada.Strings.Wide_Fixed; +with Ada.Strings.Wide_Maps; +with Report; + +procedure CXA4014 is + use CXA40140; +begin + + Report.Test ("CXA4014", "Check that the subprograms defined in package " & + "Ada.Strings.Wide_Fixed are available, and that " & + "they produce correct results"); + + Test_Block: + declare + + Number_Of_Info_Strings : constant Natural := 3; + DB_Size : constant Natural := Number_Of_Info_Strings; + Count : Natural := 0; + Finished_Processing : Boolean := False; + Blank_Wide_String : constant Wide_String := " "; + + subtype Info_Wide_String_Type is Wide_String (1..50); + type Info_Wide_String_Storage_Type is + array (1..Number_Of_Info_Strings) of Info_Wide_String_Type; + + + subtype Name_Type is Wide_String (1..10); + subtype Street_Number_Type is Wide_String (1..5); + subtype Street_Name_Type is Wide_String (1..10); + subtype City_Type is Wide_String (1..10); + subtype State_Type is Wide_String (1..2); + subtype Zip_Code_Type is Wide_String (1..5); + + type Data_Base_Element_Type is + record + Name : Name_Type := (others => ' '); + Street_Number : Street_Number_Type := (others => ' '); + Street_Name : Street_Name_Type := (others => ' '); + City : City_Type := (others => ' '); + State : State_Type := (others => ' '); + Zip_Code : Zip_Code_Type := (others => ' '); + end record; + + type Data_Base_Type is array (1..DB_Size) of Data_Base_Element_Type; + + Data_Base : Data_Base_Type; + + --- + + Info_String_1 : Info_Wide_String_Type := + "Joe_Jones 123 Sixth_St San_Diego CA 98765"; + + Info_String_2 : Info_Wide_String_Type := + "Sam_Smith 56789 S._Seventh Carlsbad CA 92177"; + + Info_String_3 : Info_Wide_String_Type := + "Jane_Brown 1219 Info_Lane Tuscon AZ 85643"; + + + Info_Strings : Info_Wide_String_Storage_Type := + (1 => Info_String_1, + 2 => Info_String_2, + 3 => Info_String_3); + + + + TC_DB_Element_1 : Data_Base_Element_Type := + ("Joe Jones ", "123 ", "Sixth St ", "San Diego ", "CA", "98765"); + + TC_DB_Element_2 : Data_Base_Element_Type := + ("Sam Smith ", "56789", "S. Seventh", "Carlsbad ", "CA", "92177"); + + TC_DB_Element_3 : Data_Base_Element_Type := + ("Jane Brown", "1219 ", "Info Lane ", "Tuscon ", "AZ", "85643"); + + TC_Data_Base : Data_Base_Type := (TC_DB_Element_1, + TC_DB_Element_2, + TC_DB_Element_3); + + --- + + + procedure Store_Information + (Info_String : in Info_Wide_String_Type; + DB_Record : in out Data_Base_Element_Type) is + + package AS renames Ada.Strings; + use type AS.Wide_Maps.Wide_Character_Set; + + Start, + Stop : Natural := 0; + + Numeric_Set : constant AS.Wide_Maps.Wide_Character_Set := + AS.Wide_Maps.To_Set("0123456789"); + + Cal : constant + AS.Wide_Maps.Wide_Character_Sequence := "CA"; + California_Set : constant AS.Wide_Maps.Wide_Character_Set := + AS.Wide_Maps.To_Set(Cal); + Arizona_Set : constant AS.Wide_Maps.Wide_Character_Set := + AS.Wide_Maps.To_Set("AZ"); + Nevada_Set : constant AS.Wide_Maps.Wide_Character_Set := + AS.Wide_Maps.To_Set("NV"); + + Blank_Ftn_Ptr : AS.Wide_Maps.Wide_Character_Mapping_Function := + US_to_Blank_Map'Access; + + begin + + -- Find the starting position of the name field (first non-blank), + -- then, from that position, find the end of the name field (first + -- blank). + + Start := AS.Wide_Fixed.Index_Non_Blank(Info_String); + Stop := AS.Wide_Fixed.Index (Info_String(Start..Info_String'Length), + AS.Wide_Maps.To_Set(Blank), + AS.Inside, + AS.Forward) - 1 ; + + -- Store the name field in the data base element field for "Name". + + DB_Record.Name := AS.Wide_Fixed.Head(Info_String(1..Stop), + DB_Record.Name'Length); + + -- Replace any underscore characters in the name field + -- that were used to separate first/middle/last names. + -- Use the overloaded version of Translate that takes an + -- access-to-subprogram value. + + AS.Wide_Fixed.Translate (DB_Record.Name, Blank_Ftn_Ptr); + + + -- Continue the extraction process; now find the position of + -- the street number in the string. + + Start := Stop + 1; + + AS.Wide_Fixed.Find_Token(Info_String(Start..Info_String'Length), + Numeric_Set, + AS.Inside, + Start, + Stop); + + -- Store the street number field in the appropriate data base + -- element. + -- No modification of the default parameters of procedure Move + -- is required. + + AS.Wide_Fixed.Move(Source => Info_String(Start..Stop), + Target => DB_Record.Street_Number); + + + -- Continue the extraction process; find the street name in the + -- info string. Skip blanks to the start of the street name, then + -- search for the index of the next blank character in the string. + + Start := AS.Wide_Fixed.Index_Non_Blank + (Info_String(Stop+1..Info_String'Length)); + + Stop := + AS.Wide_Fixed.Index(Info_String(Start..Info_String'Length), + Blank_Wide_String) - 1; + + -- Store the street name in the appropriate data base element field. + + AS.Wide_Fixed.Overwrite(DB_Record.Street_Name, + 1, + Info_String(Start..Stop)); + + -- Replace any underscore characters in the street name field + -- that were used as word separation with blanks. Again, use the + -- access-to-subprogram value to provide the mapping. + + DB_Record.Street_Name := + AS.Wide_Fixed.Translate(DB_Record.Street_Name, + Blank_Ftn_Ptr); + + + -- Continue the extraction; remove the city name from the string. + + Start := AS.Wide_Fixed.Index_Non_Blank + (Info_String(Stop+1..Info_String'Length)); + + Stop := + AS.Wide_Fixed.Index(Info_String(Start..Info_String'Length), + Blank_Wide_String) - 1; + + -- Store the city name field in the appropriate data base element. + + AS.Wide_Fixed.Replace_Slice(DB_Record.City, + 1, + DB_Record.City'Length, + Info_String(Start..Stop)); + + -- Replace any underscore characters in the city name field + -- that were used as word separation. + + AS.Wide_Fixed.Translate (DB_Record.City, + Blank_Ftn_Ptr); + + + -- Continue the extraction; remove the state identifier from the + -- info string. + + Start := Stop + 1; + + AS.Wide_Fixed.Find_Token(Info_String(Start..Info_String'Length), + AS.Wide_Maps."OR"(California_Set, + AS.Wide_Maps."OR"(Nevada_Set, + Arizona_Set)), + AS.Inside, + Start, + Stop); + + -- Store the state indicator into the data base element. + + AS.Wide_Fixed.Move(Source => Info_String(Start..Stop), + Target => DB_Record.State, + Drop => Ada.Strings.Right, + Justify => Ada.Strings.Left, + Pad => AS.Wide_Space); + + + -- Continue the extraction process; remove the final data item in + -- the info string, the zip code, and place it into the + -- corresponding data base element. + + DB_Record.Zip_Code := + AS.Wide_Fixed.Tail(Info_String, DB_Record.Zip_Code'Length); + + exception + when AS.Length_Error => + Report.Failed ("Length_Error raised in procedure"); + when AS.Pattern_Error => + Report.Failed ("Pattern_Error raised in procedure"); + when AS.Translation_Error => + Report.Failed ("Translation_Error raised in procedure"); + when others => + Report.Failed ("Exception raised in procedure"); + end Store_Information; + + + begin + + -- Loop thru the information strings, extract the name and address + -- information, place this info into elements of the data base. + + while not Finished_Processing loop + + Count := Count + 1; + + Store_Information (Info_Strings(Count), Data_Base(Count)); + + Finished_Processing := (Count = Number_Of_Info_Strings); + + end loop; + + + -- Verify that the string processing was successful. + + for i in 1..DB_Size loop + if Data_Base(i) /= TC_Data_Base(i) then + Report.Failed + ("Data processing error on record " & Integer'Image(i)); + end if; + end loop; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + + Report.Result; + +end CXA4014; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4015.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4015.a new file mode 100644 index 000000000..83fad3af8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4015.a @@ -0,0 +1,580 @@ +-- CXA4015.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 subprograms defined in package Ada.Strings.Wide_Fixed +-- are available, and that they produce correct results. Specifically, +-- check the subprograms Count, Find_Token, Index, Index_Non_Blank, and +-- Move. +-- +-- TEST DESCRIPTION: +-- This test, when combined with tests CXA4013,14,16 will provide +-- coverage of the functionality found in Ada.Strings.Wide_Fixed. +-- This test contains many small, specific test cases, situations that +-- although common in user environments, are often difficult to generate +-- in large numbers in a application-based test. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 02 Nov 95 SAIC Corrected various accesssibility problems and +-- expected result strings for ACVC 2.0.1. +-- +--! + +package CXA40150 is + + -- Wide Character mapping function defined for use with specific + -- versions of functions Index and Count. + + function AK_to_ZQ_Mapping (From : Wide_Character) return Wide_Character; + +end CXA40150; + +package body CXA40150 is + + function AK_to_ZQ_Mapping (From : Wide_Character) + return Wide_Character is + begin + if From = 'a' then + return 'z'; + elsif From = 'k' then + return 'q'; + else + return From; + end if; + end AK_to_ZQ_Mapping; + +end CXA40150; + + +with CXA40150; +with Report; +with Ada.Strings; +with Ada.Strings.Wide_Fixed; +with Ada.Strings.Wide_Maps; + +procedure CXA4015 is +begin + + Report.Test("CXA4015", "Check that the subprograms defined in " & + "package Ada.Strings.Wide_Fixed are available, " & + "and that they produce correct results"); + + + Test_Block: + declare + + use CXA40150; + + package ASF renames Ada.Strings.Wide_Fixed; + package Maps renames Ada.Strings.Wide_Maps; + + Result_String : Wide_String(1..10) := + (others => Ada.Strings.Wide_Space); + + Source_String1 : Wide_String(1..5) := "abcde"; -- odd len Wide_String + Source_String2 : Wide_String(1..6) := "abcdef"; -- even len Wide_String + Source_String3 : Wide_String(1..12) := "abcdefghijkl"; + Source_String4 : Wide_String(1..12) := "abcdefghij "; -- last 2 ch pad + Source_String5 : Wide_String(1..12) := " cdefghijkl"; -- first 2 ch pad + Source_String6 : Wide_String(1..12) := "abcdefabcdef"; + + Location : Natural := 0; + Slice_Start : Positive; + Slice_End, + Slice_Count : Natural := 0; + + CD_Set : Maps.Wide_Character_Set := Maps.To_Set("cd"); + ABCD_Set : Maps.Wide_Character_Set := Maps.To_Set("abcd"); + A_to_F_Set : Maps.Wide_Character_Set := Maps.To_Set("abcdef"); + + CD_to_XY_Map : Maps.Wide_Character_Mapping := + Maps.To_Mapping(From => "cd", To => "xy"); + + + -- Access-to-Subprogram object defined for use with specific versions of + -- functions Index and Count. + + Map_Ptr : Maps.Wide_Character_Mapping_Function := + AK_to_ZQ_Mapping'Access; + + + begin + + + -- Procedure Move + -- Evaluate the Procedure Move with various combinations of + -- parameters. + + -- Justify = Left (default case) + + ASF.Move(Source => Source_String1, -- "abcde" + Target => Result_String); + + if Result_String /= "abcde " then + Report.Failed("Incorrect result from Move with Justify = Left"); + end if; + + -- Justify = Right + + ASF.Move(Source => Source_String2, -- "abcdef" + Target => Result_String, + Drop => Ada.Strings.Error, + Justify => Ada.Strings.Right); + + if Result_String /= " abcdef" then + Report.Failed("Incorrect result from Move with Justify = Right"); + end if; + + -- Justify = Center (two cases, odd and even pad lengths) + + ASF.Move(Source_String1, -- "abcde" + Result_String, + Ada.Strings.Error, + Ada.Strings.Center, + 'x'); -- non-default padding. + + if Result_String /= "xxabcdexxx" then -- Unequal padding added right + Report.Failed("Incorrect result from Move with Justify = Center-1"); + end if; + + ASF.Move(Source_String2, -- "abcdef" + Result_String, + Ada.Strings.Error, + Ada.Strings.Center); + + if Result_String /= " abcdef " then -- Equal padding added on L/R. + Report.Failed("Incorrect result from Move with Justify = Center-2"); + end if; + + -- When the source Wide_String is longer than the target Wide_String, + -- several cases can be examined, with the results depending on the + -- value of the Drop parameter. + + -- Drop = Left + + ASF.Move(Source => Source_String3, -- "abcdefghijkl" + Target => Result_String, + Drop => Ada.Strings.Left); + + if Result_String /= "cdefghijkl" then + Report.Failed("Incorrect result from Move with Drop = Left"); + end if; + + -- Drop = Right + + ASF.Move(Source_String3, Result_String, Ada.Strings.Right); + + if Result_String /= "abcdefghij" then + Report.Failed("Incorrect result from Move with Drop = Right"); + end if; + + -- Drop = Error + -- The effect in this case depends on the value of the justify + -- parameter, and on whether any characters in Source other than + -- Pad would fail to be copied. + + -- Drop = Error, Justify = Left, right overflow characters are pad. + + ASF.Move(Source => Source_String4, -- "abcdefghij " + Target => Result_String, + Drop => Ada.Strings.Error, + Justify => Ada.Strings.Left); + + if not(Result_String = "abcdefghij") then -- leftmost 10 characters + Report.Failed("Incorrect result from Move with Drop = Error - 1"); + end if; + + -- Drop = Error, Justify = Right, left overflow characters are pad. + + ASF.Move(Source_String5, -- " cdefghijkl" + Result_String, + Ada.Strings.Error, + Ada.Strings.Right); + + if Result_String /= "cdefghijkl" then -- rightmost 10 characters + Report.Failed("Incorrect result from Move with Drop = Error - 2"); + end if; + + -- In other cases of Drop=Error, Length_Error is propagated, such as: + + begin + + ASF.Move(Source_String3, -- 12 characters, no Pad. + Result_String, -- 10 characters + Ada.Strings.Error, + Ada.Strings.Left); + + Report.Failed("Length_Error not raised by Move - 1"); + + exception + when Ada.Strings.Length_Error => null; -- OK + when others => + Report.Failed("Incorrect exception raised by Move - 1"); + end; + + + + -- Function Index + -- (Other usage examples of this function found in CXA4013-14.) + -- Check when the pattern is not found in the source. + + if ASF.Index("abcdef", "gh") /= 0 or + ASF.Index("abcde", "abcdef") /= 0 or -- pattern > source + ASF.Index("xyz", + "abcde", + Ada.Strings.Backward) /= 0 or + ASF.Index("", "ab") /= 0 or -- null source Wide_String. + ASF.Index("abcde", " ") /= 0 -- blank pattern. + then + Report.Failed("Incorrect result from Index, no pattern match"); + end if; + + -- Check that Pattern_Error is raised when the pattern is the + -- null Wide_String. + begin + Location := ASF.Index(Source_String6, -- "abcdefabcdef" + "", -- null pattern Wide_String. + Ada.Strings.Forward); + Report.Failed("Pattern_Error not raised by Index"); + exception + when Ada.Strings.Pattern_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by Index, null pattern"); + end; + + -- Use the search direction "backward" to locate the particular + -- pattern within the source Wide_String. + + Location := ASF.Index(Source_String6, -- "abcdefabcdef" + "de", -- slice 4..5, 10..11 + Ada.Strings.Backward); -- search from right end. + + if Location /= 10 then + Report.Failed("Incorrect result from Index going Backward"); + end if; + + + + -- Function Index + -- Use the version of Index that takes a Wide_Character_Mapping_Function + -- parameter. + -- Use the search directions Forward and Backward to locate the + -- particular pattern wide string within the source wide string. + + Location := ASF.Index("akzqefakzqef", + "qzq", -- slice 8..10 + Ada.Strings.Backward, + Map_Ptr); -- perform 'a' to 'z', 'k' to 'q' + -- translation. + if Location /= 8 then + Report.Failed + ("Incorrect result from Index w/map ptr going Backward"); + end if; + + Location := ASF.Index("ddkkddakcdakdefcadckdfzaaqd", + "zq", -- slice 7..8 + Ada.Strings.Forward, + Map_Ptr); -- perform 'a' to 'z', 'k' to 'q' + -- translation. + if Location /= 7 then + Report.Failed + ("Incorrect result from Index w/map ptr going Forward"); + end if; + + + if ASF.Index("aakkzq", "zq", Ada.Strings.Forward, Map_Ptr) /= 2 or + ASF.Index("qzedka", "qz", Ada.Strings.Backward, Map_Ptr) /= 5 or + ASF.Index("zazaza", "zzzz", Ada.Strings.Backward, Map_Ptr) /= 3 or + ASF.Index("kka", "qqz", Ada.Strings.Forward, Map_Ptr) /= 1 + then + Report.Failed("Incorrect result from Index w/map ptr"); + end if; + + + -- Check when the pattern wide string is not found in the source. + + if ASF.Index("akzqef", "kzq", Ada.Strings.Forward, Map_Ptr) /= 0 or + ASF.Index("abcde", "abcdef", Ada.Strings.Backward, Map_Ptr) /= 0 or + ASF.Index("xyz", "akzde", Ada.Strings.Backward, Map_Ptr) /= 0 or + ASF.Index("", "zq", Ada.Strings.Forward, Map_Ptr) /= 0 or + ASF.Index("akcde", " ", Ada.Strings.Backward, Map_Ptr) /= 0 + then + Report.Failed + ("Incorrect result from Index w/map ptr, no pattern match"); + end if; + + -- Check that Pattern_Error is raised when the pattern is a + -- null Wide_String. + begin + Location := ASF.Index("akzqefakqzef", + "", -- null pattern Wide_String. + Ada.Strings.Forward, + Map_Ptr); + Report.Failed("Pattern_Error not raised by Index w/map ptr"); + exception + when Ada.Strings.Pattern_Error => null; -- OK, expected exception. + when others => + Report.Failed + ("Incorrect exception raised by Index w/map ptr, null pattern"); + end; + + + + -- Function Index + -- Using the version of Index testing wide character set membership, + -- check combinations of forward/backward, inside/outside parameter + -- configurations. + + if ASF.Index(Source => Source_String1, -- "abcde" + Set => CD_Set, + Test => Ada.Strings.Inside, + Going => Ada.Strings.Forward) /= 3 or -- 'c' at pos 3. + ASF.Index(Source_String6, -- "abcdefabcdef" + CD_Set, + Ada.Strings.Outside, + Ada.Strings.Backward) /= 12 or -- 'f' at position 12 + ASF.Index(Source_String6, -- "abcdefabcdef" + CD_Set, + Ada.Strings.Inside, + Ada.Strings.Backward) /= 10 or -- 'd' at position 10 + ASF.Index("cdcdcdcdacdcdcdcd", + CD_Set, + Ada.Strings.Outside, + Ada.Strings.Forward) /= 9 -- 'a' at position 9 + then + Report.Failed("Incorrect result from function Index for sets - 1"); + end if; + + -- Additional interesting uses/combinations using Index for sets. + + if ASF.Index("cd", -- same size, str-set + CD_Set, + Ada.Strings.Inside, + Ada.Strings.Forward) /= 1 or -- 'c' at position 1 + ASF.Index("abcd", -- same size, str-set, + Maps.To_Set("efgh"), -- different contents. + Ada.Strings.Outside, + Ada.Strings.Forward) /= 1 or + ASF.Index("abccd", -- set > Wide_String + Maps.To_Set("acegik"), + Ada.Strings.Inside, + Ada.Strings.Backward) /= 4 or -- 'c' at position 4 + ASF.Index("abcde", + Maps.Null_Set) /= 0 or + ASF.Index("", -- Null string. + CD_Set) /= 0 or + ASF.Index("abc ab", -- blank included + Maps.To_Set("e "), -- in Wide_String and + Ada.Strings.Inside, -- set. + Ada.Strings.Backward) /= 4 -- blank in Wide_Str. + then + Report.Failed("Incorrect result from function Index for sets - 2"); + end if; + + + + -- Function Index_Non_Blank. + -- (Other usage examples of this function found in CXA4013-14.) + + + if ASF.Index_Non_Blank(Source => Source_String4, -- "abcdefghij " + Going => Ada.Strings.Backward) /= 10 or + ASF.Index_Non_Blank("abc def ghi jkl ", + Ada.Strings.Backward) /= 15 or + ASF.Index_Non_Blank(" abcdef") /= 3 or + ASF.Index_Non_Blank(" ") /= 0 + then + Report.Failed("Incorrect result from Index_Non_Blank"); + end if; + + + + -- Function Count + -- (Other usage examples of this function found in CXA4013-14.) + + if ASF.Count("abababa", "aba") /= 2 or + ASF.Count("abababa", "ab" ) /= 3 or + ASF.Count("babababa", "ab") /= 3 or + ASF.Count("abaabaaba", "aba") /= 3 or + ASF.Count("xxxxxxxxxxxxxxxxxxxy", "xy") /= 1 or + ASF.Count("xxxxxxxxxxxxxxxxxxxx", "x") /= 20 + then + Report.Failed("Incorrect result from Function Count"); + end if; + + -- Determine the number of slices of Source that when mapped to a + -- non-identity map, match the pattern Wide_String. + + Slice_Count := ASF.Count(Source_String6, -- "abcdefabcdef" + "xy", + CD_to_XY_Map); -- maps 'c' to 'x', 'd' to 'y' + + if Slice_Count /= 2 then -- two slices "xy" in "mapped" Source_String6 + Report.Failed("Incorrect result from Count with non-identity map"); + end if; + + -- If the pattern supplied to Function Count is the null Wide_String, + -- then Pattern_Error is propagated. + declare + The_Null_Wide_String : constant Wide_String := ""; + begin + Slice_Count := ASF.Count(Source_String6, The_Null_Wide_String); + Report.Failed("Pattern_Error not raised by Function Count"); + exception + when Ada.Strings.Pattern_Error => null; -- OK + when others => + Report.Failed("Incorrect exception from Count with null pattern"); + end; + + + + + -- Function Count + -- Use the version of Count that takes a Wide_Character_Mapping_Function + -- value as the basis of its source mapping. + + if ASF.Count("akakaka", "zqz", Map_Ptr) /= 2 or + ASF.Count("akakaka", "qz", Map_Ptr) /= 3 or + ASF.Count("kakakaka", "q", Map_Ptr) /= 4 or + ASF.Count("zzqaakzaqzzk", "zzq", Map_Ptr) /= 4 or + ASF.Count(" ", "z", Map_Ptr) /= 0 or + ASF.Count("", "qz", Map_Ptr) /= 0 or + ASF.Count("abbababab", "zq", Map_Ptr) /= 0 or + ASF.Count("aaaaaaaaaaaaaaaaaakk", "zqq", Map_Ptr) /= 1 or + ASF.Count("azaazaazzzaaaaazzzza", "z", Map_Ptr) /= 20 + then + Report.Failed("Incorrect result from Function Count w/map ptr"); + end if; + + -- If the pattern supplied to Function Count is a null Wide_String, + -- then Pattern_Error is propagated. + declare + The_Null_Wide_String : constant Wide_String := ""; + begin + Slice_Count := ASF.Count(Source_String6, + The_Null_Wide_String, + Map_Ptr); + Report.Failed + ("Pattern_Error not raised by Function Count w/map ptr"); + exception + when Ada.Strings.Pattern_Error => null; -- OK + when others => + Report.Failed + ("Incorrect exception from Count w/map ptr, null pattern"); + end; + + + + + -- Function Count returning the number of characters in a particular + -- set that are found in source Wide_String. + + if ASF.Count(Source_String6, CD_Set) /= 4 or -- 2 'c' and 'd' chars. + ASF.Count("cddaccdaccdd", CD_Set) /= 10 + then + Report.Failed("Incorrect result from Count with set"); + end if; + + + + -- Function Find_Token. + -- (Other usage examples of this function found in CXA4013-14.) + + ASF.Find_Token(Source => Source_String6, -- First slice with no + Set => ABCD_Set, -- 'a', 'b', 'c', or 'd' + Test => Ada.Strings.Outside, -- is "ef" at 5..6. + First => Slice_Start, + Last => Slice_End); + + if Slice_Start /= 5 or Slice_End /= 6 then + Report.Failed("Incorrect result from Find_Token - 1"); + end if; + + -- If no appropriate slice is contained by the source Wide_String, + -- then the value returned in Last is zero, and the value in First is + -- Source'First. + + ASF.Find_Token(Source_String6, -- "abcdefabcdef" + A_to_F_Set, -- Set of characters 'a' thru 'f'. + Ada.Strings.Outside, -- No characters outside this set. + Slice_Start, + Slice_End); + + if Slice_Start /= Source_String6'First or Slice_End /= 0 then + Report.Failed("Incorrect result from Find_Token - 2"); + end if; + + -- Additional testing of Find_Token. + + ASF.Find_Token("eabcdabcddcab", + ABCD_Set, + Ada.Strings.Inside, + Slice_Start, + Slice_End); + + if Slice_Start /= 2 or Slice_End /= 13 then + Report.Failed("Incorrect result from Find_Token - 3"); + end if; + + ASF.Find_Token("efghijklabcdabcd", + ABCD_Set, + Ada.Strings.Outside, + Slice_Start, + Slice_End); + + if Slice_Start /= 1 or Slice_End /= 8 then + Report.Failed("Incorrect result from Find_Token - 4"); + end if; + + ASF.Find_Token("abcdefgabcdabcd", + ABCD_Set, + Ada.Strings.Outside, + Slice_Start, + Slice_End); + + if Slice_Start /= 5 or Slice_End /= 7 then + Report.Failed("Incorrect result from Find_Token - 5"); + end if; + + ASF.Find_Token("abcdcbabcdcba", + ABCD_Set, + Ada.Strings.Inside, + Slice_Start, + Slice_End); + + if Slice_Start /= 1 or Slice_End /= 13 then + Report.Failed("Incorrect result from Find_Token - 6"); + end if; + + + exception + when others => Report.Failed("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + +end CXA4015; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4016.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4016.a new file mode 100644 index 000000000..00dcdcdbd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4016.a @@ -0,0 +1,685 @@ +-- CXA4016.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 subprograms defined in package Ada.Strings.Wide_Fixed +-- are available, and that they produce correct results. Specifically, +-- check the subprograms Delete, Head, Insert, Overwrite, Replace_Slice, +-- Tail, Trim, and "*". +-- +-- TEST DESCRIPTION: +-- This test, when combined with tests CXA4013-15 will provide +-- coverage of the functionality found in package Ada.Strings.Wide_Fixed. +-- This test contains many small, specific test cases, situations that +-- although common in user environments, are often difficult to generate +-- in large numbers in a application-based test. They represent +-- individual usage paradigms in-the-small. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 10 Apr 94 SAIC Modified comments in a subtest failure message. +-- 06 Nov 95 SAIC Corrected subtest results for ACVC 2.0.1 +-- 14 Mar 01 RLB Added checks that the lower bound is 1, similar +-- to CXA4005. These changes were made to test +-- Defect Report 8652/0049, as reflected in +-- Technical Corrigendum 1. +-- +--! + +with Report; +with Ada.Strings; +with Ada.Strings.Wide_Fixed; +with Ada.Strings.Wide_Maps; + +procedure CXA4016 is + + type TC_Name_Holder is access String; + Name : TC_Name_Holder; + + function TC_Check (S : Wide_String) return Wide_String is + begin + if S'First /= 1 then + Report.Failed ("Lower bound of result of function " & Name.all & + " is" & Integer'Image (S'First)); + end if; + return S; + end TC_Check; + + procedure TC_Set_Name (N : String) is + begin + Name := new String'(N); + end TC_Set_Name; + +begin + + Report.Test("CXA4016", "Check that the subprograms defined in " & + "package Ada.Strings.Wide_Fixed are available, " & + "and that they produce correct results"); + + Test_Block: + declare + + package ASW renames Ada.Strings.Wide_Fixed; + package Wide_Maps renames Ada.Strings.Wide_Maps; + + Result_String, + Delete_String, + Insert_String, + Trim_String, + Overwrite_String : Wide_String(1..10) := + (others => Ada.Strings.Wide_Space); + Replace_String : Wide_String(10..30) := + (others => Ada.Strings.Wide_Space); + + Source_String1 : Wide_String(1..5) := "abcde"; -- odd len wd str + Source_String2 : Wide_String(1..6) := "abcdef"; -- even len wd str + Source_String3 : Wide_String(1..12) := "abcdefghijkl"; + Source_String4 : Wide_String(1..12) := "abcdefghij "; -- last two ch pad + Source_String5 : Wide_String(1..12) := " cdefghijkl"; -- first two ch pad + Source_String6 : Wide_String(1..12) := "abcdefabcdef"; + + Location : Natural := 0; + Slice_Start : Positive; + Slice_End, + Slice_Count : Natural := 0; + + CD_Set : Wide_Maps.Wide_Character_Set := + Wide_Maps.To_Set("cd"); + X_Set : Wide_Maps.Wide_Character_Set := + Wide_Maps.To_Set('x'); + ABCD_Set : Wide_Maps.Wide_Character_Set := + Wide_Maps.To_Set("abcd"); + A_to_F_Set : Wide_Maps.Wide_Character_Set := + Wide_Maps.To_Set("abcdef"); + + CD_to_XY_Map : Wide_Maps.Wide_Character_Mapping := + Wide_Maps.To_Mapping(From => "cd", To => "xy"); + + begin + + -- Procedure Replace_Slice + -- The functionality of this procedure is similar to procedure Move, + -- and is tested here in the same manner, evaluated with various + -- combinations of parameters. + + -- Index_Error propagation when Low > Source'Last + 1 + + begin + ASW.Replace_Slice(Result_String, + Result_String'Last + 2, -- should raise exception + Result_String'Last, + "xxxxxxx"); + Report.Failed("Index_Error not raised by Replace_Slice - 1"); + exception + when Ada.Strings.Index_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception from Replace_Slice - 1"); + end; + + -- Index_Error propagation when High < Source'First - 1 + + begin + ASW.Replace_Slice(Replace_String(20..30), + Replace_String'First, + Replace_String'First - 2, -- should raise exception + "xxxxxxx"); + Report.Failed("Index_Error not raised by Replace_Slice - 2"); + exception + when Ada.Strings.Index_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception from Replace_Slice - 2"); + end; + + -- Justify = Left (default case) + + Result_String := "XXXXXXXXXX"; + + ASW.Replace_Slice(Source => Result_String, + Low => 1, + High => 10, + By => Source_String1); -- "abcde" + + if Result_String /= "abcde " then + Report.Failed("Incorrect result from Replace_Slice - Justify = Left"); + end if; + + -- Justify = Right + + ASW.Replace_Slice(Source => Result_String, + Low => 1, + High => Result_String'Last, + By => Source_String2, -- "abcdef" + Drop => Ada.Strings.Error, + Justify => Ada.Strings.Right); + + if Result_String /= " abcdef" then + Report.Failed("Incorrect result from Replace_Slice - Justify=Right"); + end if; + + -- Justify = Center (two cases, odd and even pad lengths) + + ASW.Replace_Slice(Result_String, + 1, + Result_String'Last, + Source_String1, -- "abcde" + Ada.Strings.Error, + Ada.Strings.Center, + 'x'); -- non-default padding. + + if Result_String /= "xxabcdexxx" then -- Unequal padding added right + Report.Failed("Incorrect result, Replace_Slice - Justify=Center - 1"); + end if; + + ASW.Replace_Slice(Result_String, + 1, + Result_String'Last, + Source_String2, -- "abcdef" + Ada.Strings.Error, + Ada.Strings.Center); + + if Result_String /= " abcdef " then -- Equal padding added on L/R. + Report.Failed("Incorrect result from Replace_Slice with " & + "Justify = Center - 2"); + end if; + + -- When the source string is longer than the target string, several + -- cases can be examined, with the results depending on the value of + -- the Drop parameter. + + -- Drop = Left + + ASW.Replace_Slice(Result_String, + 1, + Result_String'Last, + Source_String3, -- "abcdefghijkl" + Drop => Ada.Strings.Left); + + if Result_String /= "cdefghijkl" then + Report.Failed("Incorrect result from Replace_Slice - Drop=Left"); + end if; + + -- Drop = Right + + ASW.Replace_Slice(Result_String, + 1, + Result_String'Last, + Source_String3, -- "abcdefghijkl" + Ada.Strings.Right); + + if Result_String /= "abcdefghij" then + Report.Failed("Incorrect result, Replace_Slice with Drop=Right"); + end if; + + -- Drop = Error + + -- The effect in this case depends on the value of the justify + -- parameter, and on whether any characters in Source other than + -- Pad would fail to be copied. + + -- Drop = Error, Justify = Left, right overflow characters are pad. + + ASW.Replace_Slice(Result_String, + 1, + Result_String'Last, + Source_String4, -- "abcdefghij " + Drop => Ada.Strings.Error, + Justify => Ada.Strings.Left); + + if not(Result_String = "abcdefghij") then -- leftmost 10 characters + Report.Failed("Incorrect result, Replace_Slice - Drop = Error - 1"); + end if; + + -- Drop = Error, Justify = Right, left overflow characters are pad. + + ASW.Replace_Slice(Source => Result_String, + Low => 1, + High => Result_String'Last, + By => Source_String5, -- " cdefghijkl" + Drop => Ada.Strings.Error, + Justify => Ada.Strings.Right); + + if Result_String /= "cdefghijkl" then -- rightmost 10 characters + Report.Failed("Incorrect result, Replace_Slice - Drop = Error - 2"); + end if; + + -- In other cases of Drop=Error, Length_Error is propagated, such as: + + begin + + ASW.Replace_Slice(Source => Result_String, + Low => 1, + High => Result_String'Last, + By => Source_String3, -- "abcdefghijkl" + Drop => Ada.Strings.Error); + + Report.Failed("Length_Error not raised by Replace_Slice - 1"); + + exception + when Ada.Strings.Length_Error => null; -- OK + when others => + Report.Failed("Incorrect exception from Replace_Slice - 3"); + end; + + + -- Function Replace_Slice + + TC_Set_Name ("Replace_Slice"); + + if TC_Check (ASW.Replace_Slice("abcde", 3, 3, "x")) + /= "abxde" or -- High = Low + TC_Check (ASW.Replace_Slice("abc", 2, 3, "xyz")) /= "axyz" or + TC_Check (ASW.Replace_Slice("abcd", 4, 1, "xy")) + /= "abcxyd" or -- High < Low + TC_Check (ASW.Replace_Slice("abc", 2, 3, "x")) /= "ax" or + TC_Check (ASW.Replace_Slice("a", 1, 1, "z")) /= "z" + then + Report.Failed("Incorrect result from Function Replace_Slice - 1"); + end if; + + if TC_Check (ASW.Replace_Slice("abcde", 5, 5, "z")) + /= "abcdz" or -- By length 1 + TC_Check (ASW.Replace_Slice("abc", 1, 3, "xyz")) + /= "xyz" or -- High > Low + TC_Check (ASW.Replace_Slice("abc", 3, 2, "xy")) + /= "abxyc" or -- insert + TC_Check (ASW.Replace_Slice("a", 1, 1, "xyz")) /= "xyz" + then + Report.Failed("Incorrect result from Function Replace_Slice - 2"); + end if; + + + + -- Function Insert. + + TC_Set_Name ("Insert"); + + declare + New_String : constant Wide_String := + TC_Check ( + ASW.Insert(Source => Source_String1(2..5), -- "bcde" + Before => 2, + New_Item => Source_String2)); -- "abcdef" + begin + if New_String /= "abcdefbcde" then + Report.Failed("Incorrect result from Function Insert - 1"); + end if; + end; + + if TC_Check (ASW.Insert("a", 1, "z")) /= "za" or + TC_Check (ASW.Insert("abc", 3, "")) /= "abc" or + TC_Check (ASW.Insert("abc", 4, "z")) /= "abcz" + then + Report.Failed("Incorrect result from Function Insert - 2"); + end if; + + begin + if TC_Check (ASW.Insert(Source => Source_String1(2..5), -- "bcde" + Before => Report.Ident_Int(7), + New_Item => Source_String2)) -- "abcdef" + /= "babcdefcde" then + Report.Failed("Index_Error not raised by Insert - 3A"); + else + Report.Failed("Index_Error not raised by Insert - 3B"); + end if; + exception + when Ada.Strings.Index_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception from Insert - 3"); + end; + + + -- Procedure Insert + + -- Drop = Right + + ASW.Insert(Source => Insert_String, + Before => 6, + New_Item => Source_String2, -- "abcdef" + Drop => Ada.Strings.Right); + + if Insert_String /= " abcde" then -- last char of New_Item dropped. + Report.Failed("Incorrect result from Insert with Drop = Right"); + end if; + + -- Drop = Left + + ASW.Insert(Source => Insert_String, -- 10 char string + Before => 2, -- 9 chars, 2..10 available + New_Item => Source_String3, -- 12 characters long. + Drop => Ada.Strings.Left); -- truncate from Left. + + if Insert_String /= "l abcde" then -- 10 chars, leading blank. + Report.Failed("Incorrect result from Insert with Drop=Left"); + end if; + + -- Drop = Error + + begin + ASW.Insert(Source => Result_String, -- 10 chars + Before => Result_String'Last, + New_Item => "abcdefghijk", + Drop => Ada.Strings.Error); + Report.Failed("Exception not raised by Procedure Insert"); + exception + when Ada.Strings.Length_Error => null; -- OK, expected exception + when others => + Report.Failed("Incorrect exception raised by Procedure Insert"); + end; + + + + -- Function Overwrite + + TC_Set_Name ("Overwrite"); + + Overwrite_String := TC_Check ( + ASW.Overwrite(Result_String, -- 10 chars + 1, -- starting at pos=1 + Source_String3(1..10))); + + if Overwrite_String /= Source_String3(1..10) then + Report.Failed("Incorrect result from Function Overwrite - 1"); + end if; + + + if TC_Check (ASW.Overwrite("abcdef", 4, "xyz")) /= "abcxyz" or + TC_Check (ASW.Overwrite("a", 1, "xyz")) + /= "xyz" or -- chars appended + TC_Check (ASW.Overwrite("abc", 3, " ")) + /= "ab " or -- blanks appended + TC_Check (ASW.Overwrite("abcde", 1, "z" )) /= "zbcde" + then + Report.Failed("Incorrect result from Function Overwrite - 2"); + end if; + + + + -- Procedure Overwrite, with truncation. + + ASW.Overwrite(Source => Overwrite_String, -- 10 characters. + Position => 1, + New_Item => Source_String3, -- 12 characters. + Drop => Ada.Strings.Left); + + if Overwrite_String /= "cdefghijkl" then + Report.Failed("Incorrect result from Overwrite with Drop=Left"); + end if; + + -- The default drop value is Right, used here. + + ASW.Overwrite(Source => Overwrite_String, -- 10 characters. + Position => 1, + New_Item => Source_String3); -- 12 characters. + + if Overwrite_String /= "abcdefghij" then + Report.Failed("Incorrect result from Overwrite with Drop=Right"); + end if; + + -- Drop = Error + + begin + ASW.Overwrite(Source => Overwrite_String, -- 10 characters. + Position => 1, + New_Item => Source_String3, -- 12 characters. + Drop => Ada.Strings.Error); + Report.Failed("Exception not raised by Procedure Overwrite"); + exception + when Ada.Strings.Length_Error => null; -- OK, expected exception. + when others => + Report.Failed + ("Incorrect exception raised by Procedure Overwrite"); + end; + + Overwrite_String := "ababababab"; + ASW.Overwrite(Overwrite_String, Overwrite_String'Last, "z"); + ASW.Overwrite(Overwrite_String, Overwrite_String'First,"z"); + ASW.Overwrite(Overwrite_String, 5, "zz"); + + if Overwrite_String /= "zbabzzabaz" then + Report.Failed("Incorrect result from Procedure Overwrite"); + end if; + + + + -- Function Delete + + TC_Set_Name ("Delete"); + + declare + New_String1 : constant Wide_String := -- Returns a 4 char wide str. + TC_Check (ASW.Delete(Source => Source_String3, + From => 3, + Through => 10)); + New_String2 : constant Wide_String := -- This returns Source. + TC_Check (ASW.Delete(Source_String3, 10, 3)); + begin + if New_String1 /= "abkl" or + New_String2 /= Source_String3 + then + Report.Failed("Incorrect result from Function Delete - 1"); + end if; + end; + + if TC_Check (ASW.Delete("a", 1, 1)) + /= "" or -- Source length = 1 + TC_Check (ASW.Delete("abc", 1, 2)) + /= "c" or -- From = Source'First + TC_Check (ASW.Delete("abc", 3, 3)) + /= "ab" or -- From = Source'Last + TC_Check (ASW.Delete("abc", 3, 1)) + /= "abc" -- From > Through + then + Report.Failed("Incorrect result from Function Delete - 2"); + end if; + + + + -- Procedure Delete + + -- Justify = Left + + Delete_String := Source_String3(1..10); -- Initialize to "abcdefghij" + + ASW.Delete(Source => Delete_String, + From => 6, + Through => Delete_String'Last, + Justify => Ada.Strings.Left, + Pad => 'x'); -- pad with char 'x' + + if Delete_String /= "abcdexxxxx" then + Report.Failed("Incorrect result from Delete - Justify = Left"); + end if; + + -- Justify = Right + + ASW.Delete(Source => Delete_String, -- Remove x"s from end and + From => 6, -- shift right. + Through => Delete_String'Last, + Justify => Ada.Strings.Right, + Pad => 'x'); -- pad with char 'x' on left. + + if Delete_String /= "xxxxxabcde" then + Report.Failed("Incorrect result from Delete - Justify = Right"); + end if; + + -- Justify = Center + + ASW.Delete(Source => Delete_String, + From => 1, + Through => 5, + Justify => Ada.Strings.Center, + Pad => 'z'); + + if Delete_String /= "zzabcdezzz" then -- extra pad char on right side. + Report.Failed("Incorrect result from Delete - Justify = Center"); + end if; + + + + -- Function Trim + -- Use non-identity character sets to perform the trim operation. + + TC_Set_Name ("Trim"); + + Trim_String := "cdabcdefcd"; + + -- Remove the "cd" from each end of the string. This will not effect + -- the "cd" slice at 5..6. + + declare + New_String : constant Wide_String := + TC_Check (ASW.Trim(Source => Trim_String, + Left => CD_Set, Right => CD_Set)); + begin + if New_String /= Source_String2 then -- string "abcdef" + Report.Failed + ("Incorrect result from Trim with wide character sets"); + end if; + end; + + if TC_Check (ASW.Trim("abcdef", Wide_Maps.Null_Set, Wide_Maps.Null_Set)) + /= "abcdef" then + Report.Failed("Incorrect result from Trim with Null sets"); + end if; + + if TC_Check (ASW.Trim("cdxx", CD_Set, X_Set)) /= "" then + Report.Failed("Incorrect result from Trim, wide string removal"); + end if; + + + -- Procedure Trim + + -- Justify = Right + + ASW.Trim(Source => Trim_String, + Left => CD_Set, + Right => CD_Set, + Justify => Ada.Strings.Right, + Pad => 'x'); + + if Trim_String /= "xxxxabcdef" then + Report.Failed("Incorrect result from Trim with Justify = Right"); + end if; + + -- Justify = Left + + ASW.Trim(Source => Trim_String, + Left => X_Set, + Right => Wide_Maps.Null_Set, + Justify => Ada.Strings.Left, + Pad => ' '); + + if Trim_String /= "abcdef " then -- Padded with 4 blanks on right. + Report.Failed("Incorrect result from Trim with Justify = Left"); + end if; + + -- Justify = Center + + ASW.Trim(Source => Trim_String, + Left => ABCD_Set, + Right => CD_Set, + Justify => Ada.Strings.Center, + Pad => 'x'); + + if Trim_String /= "xxef xx" then -- Padded with 4 pad chars on L/R + Report.Failed("Incorrect result from Trim with Justify = Center"); + end if; + + + + -- Function Head, testing use of padding. + + TC_Set_Name ("Head"); + + -- Use the wide characters of Source_String1 ("abcde") and pad the + -- last five wide characters of Result_String with 'x' wide characters. + + Result_String := TC_CHeck (ASW.Head(Source_String1, 10, 'x')); + + if Result_String /= "abcdexxxxx" then + Report.Failed("Incorrect result from Function Head with padding"); + end if; + + if TC_Check (ASW.Head(" ab ", 2)) /= " " or + TC_Check (ASW.Head("a", 6, 'A')) /= "aAAAAA" or + TC_Check (ASW.Head(ASW.Head("abc ", 7, 'x'), 10, 'X')) + /= "abc xxXXX" + then + Report.Failed("Incorrect result from Function Head"); + end if; + + + + -- Function Tail, testing use of padding. + + TC_Set_Name ("Tail"); + + -- Use the wide characters of Source_String1 ("abcde") and pad the + -- first five wide characters of Result_String with 'x' wide characters. + + Result_String := TC_Check (ASW.Tail(Source_String1, 10, 'x')); + + if Result_String /= "xxxxxabcde" then + Report.Failed("Incorrect result from Function Tail with padding"); + end if; + + if TC_Check (ASW.Tail("abcde ", 5)) + /= "cde " or -- blanks, back + TC_Check (ASW.Tail(" abc ", 8, ' ')) + /= " abc " or -- blanks, front/back + TC_Check (ASW.Tail("", 5, 'Z')) + /= "ZZZZZ" or -- pad characters only + TC_Check (ASW.Tail("abc", 0)) + /= "" or -- null result + TC_Check (ASW.Tail(ASW.Tail(" abc ", 6, 'x'), + 10, + 'X')) /= "XXXXx abc " + then + Report.Failed("Incorrect result from Function Tail"); + end if; + + + + -- Function "*" - with (Natural, Wide_String) parameters + + TC_Set_Name ("""*"""); + + if TC_Check (ASW."*"(3, Source_String1)) /= "abcdeabcdeabcde" or + TC_Check (ASW."*"(2, Source_String2)) /= Source_String6 or + TC_Check (ASW."*"(4, Source_String1(1..2))) /= "abababab" or + TC_Check (ASW."*"(0, Source_String1)) /= "" + then + Report.Failed + ("Incorrect result from Function ""*"" with wide strings"); + end if; + + exception + when others => Report.Failed("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + +end CXA4016; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4017.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4017.a new file mode 100644 index 000000000..8d6886897 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4017.a @@ -0,0 +1,337 @@ +-- CXA4017.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 subprograms defined in package Ada.Strings.Wide_Bounded +-- are available, and that they produce correct results. Specifically, +-- check the subprograms Append, Delete, Index, Insert , Length, +-- Overwrite, Replace_Slice, Slice, "&", To_Bounded_Wide_String, +-- To_Wide_String, Translate, and Trim. +-- +-- TEST DESCRIPTION: +-- This test demonstrates the uses of a variety of the Wide_String +-- functions found in the package Ada.Strings.Wide_Bounded, simulating +-- the operations found in a text processing environment. +-- With bounded wide strings, the length of each "line" of text can vary +-- up to the instantiated maximum, allowing one to view a page of text as +-- a series of expandable lines. This provides flexibility in text +-- formatting of individual lines (wide strings). +-- Several subprograms are defined, all of which attempt to take +-- advantage of as many different bounded wide string utilities as +-- possible. Often, an operation that is being performed in a subprogram +-- using a certain bounded wide string utility could more efficiently be +-- performed using a different utility. However, in the interest of +-- including as broad coverage as possible, a mixture of utilities is +-- invoked in this test. +-- A simulated page of text is provided as a parameter to the test +-- defined subprograms, and the appropriate processing performed. The +-- processed page of text is then compared to a predefined "finished" +-- page, and test passage/failure is based on the results of this +-- comparison. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 06 Nov 95 SAIC Corrected initialization error for ACVC 2.0.1. +-- +--! + +with Ada.Strings; +with Ada.Strings.Wide_Bounded; +with Ada.Strings.Wide_Maps; +with Report; + +procedure CXA4017 is + +begin + + Report.Test ("CXA4017", "Check that the subprograms defined in package " & + "Ada.Strings.Wide_Bounded are available, and " & + "that they produce correct results"); + + Test_Block: + declare + + Characters_Per_Line : constant Positive := 40; + Lines_Per_Page : constant Natural := 4; + + + package BS_40 is new + Ada.Strings.Wide_Bounded.Generic_Bounded_Length(Characters_Per_Line); + + use type BS_40.Bounded_Wide_String; + + type Page_Type is array (1..Lines_Per_Page) of + BS_40.Bounded_Wide_String; + + -- Note: Misspellings below are intentional. + + Line1 : BS_40.Bounded_Wide_String := + BS_40.To_Bounded_Wide_String + ("ada is a progrraming language designed"); + Line2 : BS_40.Bounded_Wide_String := + BS_40.To_Bounded_Wide_String("to support the construction of long-"); + Line3 : BS_40.Bounded_Wide_String := + BS_40.To_Bounded_Wide_String("lived, highly reliabel software "); + Line4 : BS_40.Bounded_Wide_String := + BS_40.To_Bounded_Wide_String("systems"); + + Page : Page_Type := (1 => Line1, 2 => Line2, 3 => Line3, 4 => Line4); + + Finished_Page : Page_Type := + (BS_40.To_Bounded_Wide_String + ("Ada is a programming language designed"), + BS_40.To_Bounded_Wide_String("to support the construction of long-"), + BS_40.To_Bounded_Wide_String + ("lived, HIGHLY RELIABLE software systems."), + BS_40.To_Bounded_Wide_String("")); + + --- + + procedure Compress (Page : in out Page_Type) is + Clear_Line : Natural := Lines_Per_Page; + begin + -- If two consecutive lines on the page are together less than the + -- maximum line length, then append those two lines, move up all + -- lower lines on the page, and blank out the last line. + -- This algorithm works one time through the page, does not perform + -- repetitive compression, and is designed for use with this test + -- program only. + for i in 1..Lines_Per_Page - 1 loop + if BS_40.Length(Page(i)) + BS_40.Length(Page(i+1)) <= + BS_40.Max_Length + then + Page(i) := BS_40."&"(Page(i), + Page(i+1)); -- "&" (wd bnd, wd bnd) + + for j in i+1..Lines_Per_Page - 1 loop + Page(j) := + BS_40.To_Bounded_Wide_String + (BS_40.Slice(Page(j+1), + 1, + BS_40.Length(Page(j+1)))); + Clear_Line := j + 1; + end loop; + Page(Clear_Line) := BS_40.Null_Bounded_Wide_String; + end if; + end loop; + end Compress; + + --- + + procedure Format (Page : in out Page_Type) is + Sm_Ada : BS_40.Bounded_Wide_String := + BS_40.To_Bounded_Wide_String("ada"); + Cap_Ada : constant Wide_String := "Ada"; + Char_Pos : Natural := 0; + Finished : Boolean := False; + Line : Natural := Page_Type'Last; + begin + + -- Add a period to the end of the last line. + while Line >= Page_Type'First and not Finished loop + if Page(Line) /= BS_40.Null_Bounded_Wide_String and + BS_40.Length(Page(Line)) <= BS_40.Max_Length + then + Page(Line) := BS_40.Append(Page(Line), '.'); + Finished := True; + end if; + Line := Line - 1; + end loop; + + -- Replace all occurrences of "ada" with "Ada". + for Line in Page_Type'First .. Page_Type'Last loop + Finished := False; + while not Finished loop + Char_Pos := + BS_40.Index (Source => Page(Line), + Pattern => BS_40.To_Wide_String(Sm_Ada), + Going => Ada.Strings.Backward); + -- A zero is returned by function Index if no occurrences of + -- the pattern wide string are found. + Finished := (Char_Pos = 0); + if not Finished then + BS_40.Replace_Slice + (Source => Page(Line), + Low => Char_Pos, + High => Char_Pos + BS_40.Length(Sm_Ada) - 1, + By => Cap_Ada); + end if; + end loop; -- while loop + end loop; -- for loop + + end Format; + + --- + + procedure Spell_Check (Page : in out Page_Type) is + type Spelling_Type is (Incorrect, Correct); + type Word_Array_Type is array (Spelling_Type) + of BS_40.Bounded_Wide_String; + type Dictionary_Type is array (1..2) of Word_Array_Type; + + -- Note that the "words" in the dictionary will require various + -- amounts of Trimming prior to their use in the bounded wide string + -- functions. + Dictionary : Dictionary_Type := + (1 => (BS_40.To_Bounded_Wide_String(" reliabel "), + BS_40.To_Bounded_Wide_String(" reliable ")), + 2 => (BS_40.To_Bounded_Wide_String(" progrraming "), + BS_40.To_Bounded_Wide_String(" programming "))); + + Pos : Natural := Natural'First; + Finished : Boolean := False; + + begin + + for Line in Page_Type'Range loop + + -- Search for the first incorrectly spelled word in the + -- Dictionary, if it is found, replace it with the correctly + -- spelled word, using the Overwrite function. + + while not Finished loop + Pos := + BS_40.Index(Page(Line), + BS_40.To_Wide_String + (BS_40.Trim(Dictionary(1)(Incorrect), + Ada.Strings.Both)), + Ada.Strings.Forward); + Finished := (Pos = 0); + if not Finished then + Page(Line) := + BS_40.Overwrite(Page(Line), + Pos, + BS_40.To_Wide_String + (BS_40.Trim(Dictionary(1)(Correct), + Ada.Strings.Both))); + end if; + end loop; + + Finished := False; + + -- Search for the second incorrectly spelled word in the + -- Dictionary, if it is found, replace it with the correctly + -- spelled word, using the Delete procedure and Insert function. + + while not Finished loop + Pos := + BS_40.Index(Page(Line), + BS_40.To_Wide_String( + BS_40.Trim(Dictionary(2)(Incorrect), + Ada.Strings.Both)), + Ada.Strings.Forward); + + Finished := (Pos = 0); + + if not Finished then + BS_40.Delete + (Page(Line), + Pos, + Pos + BS_40.To_Wide_String + (BS_40.Trim(Dictionary(2)(Incorrect), + Ada.Strings.Both))'Length-1); + Page(Line) := + BS_40.Insert(Page(Line), + Pos, + BS_40.To_Wide_String + (BS_40.Trim(Dictionary(2)(Correct), + Ada.Strings.Both))); + end if; + end loop; + + Finished := False; + + end loop; + end Spell_Check; + + --- + + procedure Bold (Page : in out Page_Type) is + Key_Word : constant Wide_String := "highly reliable"; + Bold_Mapping : constant + Ada.Strings.Wide_Maps.Wide_Character_Mapping := + Ada.Strings.Wide_Maps.To_Mapping + (From => " abcdefghijklmnopqrstuvwxyz", + To => " ABCDEFGHIJKLMNOPQRSTUVWXYZ"); + Pos : Natural := Natural'First; + Finished : Boolean := False; + begin + -- This procedure is designed to change the case of the phrase + -- "highly reliable" into upper case (a type of "Bolding"). + -- All instances of the phrase on all lines of the page will be + -- modified. + + for Line in Page_Type'First .. Page_Type'Last loop + while not Finished loop + Pos := BS_40.Index(Page(Line), Key_Word); + Finished := (Pos = 0); + if not Finished then + + BS_40.Overwrite + (Page(Line), + Pos, + BS_40.To_Wide_String + (BS_40.Translate + (BS_40.To_Bounded_Wide_String + (BS_40.Slice(Page(Line), + Pos, + Pos + Key_Word'Length - 1)), + Bold_Mapping))); + + end if; + end loop; + Finished := False; + end loop; + end Bold; + + + begin + + Compress(Page); + Format(Page); + Spell_Check(Page); + Bold(Page); + + for i in 1..Lines_Per_Page loop + if BS_40.To_Wide_String(Page(i)) /= + BS_40.To_Wide_String(Finished_Page(i)) or + BS_40.Length(Page(i)) /= + BS_40.Length(Finished_Page(i)) + then + Report.Failed("Incorrect modification of Page, Line " & + Integer'Image(i)); + end if; + end loop; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + + Report.Result; + +end CXA4017; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4018.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4018.a new file mode 100644 index 000000000..98e0ded4a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4018.a @@ -0,0 +1,379 @@ +-- CXA4018.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 subprograms defined in package +-- Ada.Strings.Wide_Bounded are available, and that they produce +-- correct results. Specifically, check the subprograms Append, +-- Count, Element, Find_Token, Head, Index_Non_Blank, Replace_Element, +-- Replicate, Tail, To_Bounded_Wide_String, "&", ">", "<", ">=", "<=", +-- and "*". +-- +-- TEST DESCRIPTION: +-- This test, when taken in conjunction with test CXA40[17,19,20], will +-- constitute a test of all the functionality contained in package +-- Ada.Strings.Wide_Bounded. This test uses a variety of the +-- subprograms defined in the wide bounded string package in ways typical +-- of common usage. Different combinations of available subprograms +-- are used to accomplish similar wide bounded string processing goals. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 22 Dec 94 SAIC Changed obsolete constant to Strings.Wide_Space. +-- 06 Nov 95 SAIC Corrected evaluation string used in Head/Tail +-- subtests for ACVC 2.0.1. +-- +--! + +with Ada.Strings; +with Ada.Strings.Wide_Bounded; +with Ada.Characters.Handling; +with Ada.Strings.Wide_Maps; +with Report; + +procedure CXA4018 is + + -- The following two functions are used to translate character and string + -- values to "Wide" values. They will be applied to all the Wide_Bounded + -- subprogram parameters to simulate the use of Wide_Characters and + -- Wide_Strings in actual practice. Blanks are translated to Wide_Character + -- blanks and all other characters are translated into Wide_Characters with + -- position values 256 greater than their (narrow) character position + -- values. + + function Translate (Ch : Character) return Wide_Character is + C : Character := Ch; + begin + if Ch = ' ' then + return Ada.Characters.Handling.To_Wide_Character(C); + else + return Wide_Character'Val(Character'Pos(Ch) + + Character'Pos(Character'Last) + 1); + end if; + end Translate; + + function Translate (Str : String) return Wide_String is + WS : Wide_String(Str'First..Str'Last); + begin + for i in Str'First..Str'Last loop + WS(i) := Translate(Str(i)); + end loop; + return WS; + end Translate; + + +begin + + Report.Test ("CXA4018", "Check that the subprograms defined in package " & + "Ada.Strings.Wide_Bounded are available, and " & + "that they produce correct results"); + + Test_Block: + declare + + package BS80 is new Ada.Strings.Wide_Bounded.Generic_Bounded_Length(80); + use type BS80.Bounded_Wide_String; + + Part1 : constant Wide_String := Translate("Rum"); + Part2 : Wide_Character := Translate('p'); + Part3 : BS80.Bounded_Wide_String := + BS80.To_Bounded_Wide_String(Translate("el")); + Part4 : Wide_Character := Translate('s'); + Part5 : BS80.Bounded_Wide_String := + BS80.To_Bounded_Wide_String(Translate("tilt")); + Part6 : Wide_String(1..3) := Translate("ski"); + + Full_Catenate_String, + Full_Append_String, + Constructed_String, + Drop_String, + Replicated_String, + Token_String : BS80.Bounded_Wide_String; + + CharA : Wide_Character := Translate('A'); + CharB : Wide_Character := Translate('B'); + CharC : Wide_Character := Translate('C'); + CharD : Wide_Character := Translate('D'); + CharE : Wide_Character := Translate('E'); + CharF : Wide_Character := Translate('F'); + + ABStr : Wide_String(1..15) := Translate("AAAAABBBBBBBBBB"); + StrB : Wide_String(1..2) := Translate("BB"); + StrE : Wide_String(1..2) := Translate("EE"); + + + begin + + -- Evaluation of the overloaded forms of the "&" operator. + + Full_Catenate_String := + BS80."&"(Part2, -- WChar & Bnd WStr + BS80."&"(Part3, -- Bnd WStr & Bnd WStr + BS80."&"(Part4, -- WChar & Bnd WStr + BS80."&"(Part5, -- Bnd WStr & Bnd WStr + BS80.To_Bounded_Wide_String + (Part6))))); + + Full_Catenate_String := + BS80."&"(Part1, Full_Catenate_String); -- WStr & Bnd WStr + Full_Catenate_String := + BS80."&"(Left => Full_Catenate_String, + Right => Translate('n')); -- Bnd WStr & WChar + + + -- Evaluation of the overloaded forms of function Append. + + Full_Append_String := + BS80.Append(Part2, -- WChar,Bnd WStr + BS80.Append(Part3, -- Bnd WStr, Bnd WStr + BS80.Append(Part4, -- WChar,Bnd WStr + BS80.Append(BS80.To_Wide_String(Part5), -- WStr,Bnd WStr + BS80.To_Bounded_Wide_String(Part6))))); + + Full_Append_String := + BS80.Append(BS80.To_Bounded_Wide_String(Part1), -- Bnd WStr, WStr + BS80.To_Wide_String(Full_Append_String)); + + Full_Append_String := + BS80.Append(Left => Full_Append_String, + Right => Translate('n')); -- Bnd WStr, WChar + + + -- Validate the resulting bounded wide strings. + + if BS80."<"(Full_Catenate_String, Full_Append_String) or + BS80.">"(Full_Catenate_String, Full_Append_String) or + not (Full_Catenate_String = Full_Append_String and + BS80."<="(Full_Catenate_String, Full_Append_String) and + BS80.">="(Full_Catenate_String, Full_Append_String)) + then + Report.Failed + ("Incorrect results from bounded wide string catenation" & + " and comparison"); + end if; + + + -- Evaluate the overloaded forms of the Constructor function "*" and + -- the Replicate function. + + Constructed_String := + BS80."*"(2,CharA) & -- "AA" + BS80."*"(2,StrB) & -- "AABBBB" + BS80."*"(3, BS80."*"(2, CharC)) & -- "AABBBBCCCCCC" + BS80.Replicate(3, + BS80.Replicate(2, CharD)) & -- "AABBBBCCCCCCDDDDDD" + BS80.Replicate(2, StrE) & -- "AABBBBCCCCCCDDDDDDEEEE" + BS80.Replicate(2, CharF); -- "AABBBBCCCCCCDDDDDDEEEEFF" + + + -- Use of Function Replicate that involves dropping wide characters. + -- The attempt to replicate the 15 character wide string six times will + -- exceed the 80 wide character bound of the wide string. Therefore, + -- the result should be the catenation of 5 copies of the 15 character + -- wide string, followed by 5 'A' wide characters (the first five wide + -- characters of the 6th replication) with the remaining wide + -- characters of the 6th replication dropped. + + Drop_String := + BS80.Replicate(Count => 6, + Item => ABStr, -- "AAAAABBBBBBBBBB" + Drop => Ada.Strings.Right); + + if BS80.Element(Drop_String, 1) /= Translate('A') or + BS80.Element(Drop_String, 6) /= Translate('B') or + BS80.Element(Drop_String, 76) /= Translate('A') or + BS80.Element(Drop_String, 80) /= Translate('A') + then + Report.Failed("Incorrect result from Replicate with Drop"); + end if; + + + -- Use function Index_Non_Blank in the evaluation of the + -- Constructed_String. + + if BS80.Index_Non_Blank(Constructed_String, Ada.Strings.Forward) /= + BS80.To_Wide_String(Constructed_String)'First or + BS80.Index_Non_Blank(Constructed_String, Ada.Strings.Backward) /= + BS80.Length(Constructed_String) + then + Report.Failed("Incorrect results from constructor functions"); + end if; + + + + declare + + -- Define wide character set objects for use with the Count function. + -- Constructed_String = "AABBBBCCCCCCDDDDDDEEEEFF" from above. + + A_Set : Ada.Strings.Wide_Maps.Wide_Character_Set := + Ada.Strings.Wide_Maps.To_Set(BS80.Element(Constructed_String, + 1)); + B_Set : Ada.Strings.Wide_Maps.Wide_Character_Set := + Ada.Strings.Wide_Maps.To_Set(BS80.Element(Constructed_String, + 3)); + C_Set : Ada.Strings.Wide_Maps.Wide_Character_Set := + Ada.Strings.Wide_Maps.To_Set(BS80.Element(Constructed_String, + 7)); + D_Set : Ada.Strings.Wide_Maps.Wide_Character_Set := + Ada.Strings.Wide_Maps.To_Set(BS80.Element(Constructed_String, + 13)); + E_Set : Ada.Strings.Wide_Maps.Wide_Character_Set := + Ada.Strings.Wide_Maps.To_Set(BS80.Element(Constructed_String, + 19)); + F_Set : Ada.Strings.Wide_Maps.Wide_Character_Set := + Ada.Strings.Wide_Maps.To_Set(BS80.Element(Constructed_String, + 23)); + Start : Positive; + Stop : Natural := 0; + + begin + + -- Evaluate the results from function Count by comparing the number + -- of A's to the number of F's, B's to E's, and C's to D's in the + -- Constructed_String. + -- There should be an equal number of each of the wide characters that + -- are being compared (i.e., 2 A's and F's, 4 B's and E's, etc) + + if BS80.Count(Constructed_String, A_Set) /= + BS80.Count(Constructed_String, F_Set) or + BS80.Count(Constructed_String, B_Set) /= + BS80.Count(Constructed_String, E_Set) or + not (BS80.Count(Constructed_String, C_Set) = + BS80.Count(Constructed_String, D_Set)) + then + Report.Failed("Incorrect result from function Count"); + end if; + + + -- Evaluate the functions Head, Tail, and Find_Token. + -- Create the Token_String from the Constructed_String above. + + Token_String := + BS80.Tail(BS80.Head(Constructed_String, 3), 2) & -- "AB" & + BS80.Head(BS80.Tail(Constructed_String, 13), 2) & -- "CD" & + BS80.Head(BS80.Tail(Constructed_String, 3), 2); -- "EF" + + if Token_String /= + BS80.To_Bounded_Wide_String(Translate("ABCDEF")) then + Report.Failed("Incorrect result from Catenation of Token_String"); + end if; + + + -- Find the starting/ending position of the first A in the + -- Token_String (both should be 1, only one A appears in string). + -- The Function Head uses the default pad character to return a + -- bounded wide string longer than its input parameter bounded + -- wide string. + + BS80.Find_Token(BS80.Head(Token_String, 10), -- Default pad. + A_Set, + Ada.Strings.Inside, + Start, + Stop); + + if Start /= 1 and Stop /= 1 then + Report.Failed("Incorrect result from Find_Token - 1"); + end if; + + + -- Find the starting/ending position of the first non-AB slice in + -- the "head" five wide characters of Token_String (slice CDE at + -- positions 3-5) + + BS80.Find_Token(BS80.Head(Token_String, 5), -- "ABCDE" + Ada.Strings.Wide_Maps."OR"(A_Set, B_Set), -- Set (AB) + Ada.Strings.Outside, + Start, + Stop); + + if Start /= 3 and Stop /= 5 then + Report.Failed("Incorrect result from Find_Token - 2"); + end if; + + + -- Find the starting/ending position of the first CD slice in + -- the "tail" eight wide characters (including two pad wide + -- characters) of Token_String (slice CD at positions 5-6 of + -- the tail portion specified) + + BS80.Find_Token(BS80.Tail(Token_String, 8, + Ada.Strings.Wide_Space), + Ada.Strings.Wide_Maps."OR"(C_Set, D_Set), + Ada.Strings.Inside, + Start, + Stop); + + if Start /= 5 and Stop /= 6 then + Report.Failed("Incorrect result from Find_Token - 3"); + end if; + + + -- Evaluate the Replace_Element function. + + -- Token_String = "ABCDEF" + + BS80.Replace_Element(Token_String, 3, BS80.Element(Token_String,4)); + + -- Token_String = "ABDDEF" + + BS80.Replace_Element(Source => Token_String, + Index => 2, + By => BS80.Element(Token_String, 5)); + + -- Token_String = "AEDDEF" + + BS80.Replace_Element(Token_String, + 1, + BS80.Element(BS80.Tail(Token_String, 2), 2)); + + -- Token_String = "FEDDEF" + -- Evaluate this result. + + if BS80.Element(Token_String, + BS80.To_Wide_String(Token_String)'First) /= + BS80.Element(Token_String, + BS80.To_Wide_String(Token_String)'Last) or + BS80.Count(Token_String, D_Set) /= + BS80.Count(Token_String, E_Set) or + BS80.Index_Non_Blank(BS80.Head(Token_String,6)) /= + BS80.Index_Non_Blank(BS80.Tail(Token_String,6)) or + BS80.Head(Token_String, 1) /= + BS80.Tail(Token_String, 1) + then + Report.Failed("Incorrect result from operations in combination"); + end if; + + end; + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + + Report.Result; + +end CXA4018; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4019.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4019.a new file mode 100644 index 000000000..943e3e73b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4019.a @@ -0,0 +1,1027 @@ +-- CXA4019.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 subprograms defined in package Ada.Strings.Wide_Bounded +-- are available, and that they produce correct results, especially +-- under conditions where truncation of the result is required. +-- Specifically, check the subprograms Append, Count with non-Identity +-- maps, Index with non-Identity maps, Index with Set parameters, +-- Insert (function and procedure), Replace_Slice (function and +-- procedure), To_Bounded_Wide_String, and Translate (function and +-- procedure). +-- +-- TEST DESCRIPTION: +-- This test, in conjunction with tests CXA4017, CXA4018, and CXA4020, +-- will provide coverage of the most common usages of the functionality +-- found in the Ada.Strings.Wide_Bounded package. It deals in large part +-- with truncation effects and options. This test contains many small, +-- specific test cases, situations that are often difficult to generate +-- in large numbers in an application-based test. These cases represent +-- specific usage paradigms in-the-small. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 06 Nov 95 SAIC Corrected expected result string in subtest for +-- ACVC 2.0.1. +-- Moved function Dog_to_Cat_Mapping to library +-- level to correct accessibility problem in test. +-- 22 Aug 96 SAIC Corrected three subtests identified in reviewer +-- comments. +-- 17 Feb 97 PWB.CTA Corrected result strings for Translate and Insert +-- +--! + +package CXA40190 is + + -- Wide Character mapping function defined for use with specific + -- versions of functions Index and Count. + + function Dog_to_Cat_Mapping (From : Wide_Character) + return Wide_Character; + +end CXA40190; + +package body CXA40190 is + + -- Translates "dog" to "cat". + function Dog_to_Cat_Mapping (From : Wide_Character) + return Wide_Character is + begin + if From = 'd' then + return 'c'; + elsif From = 'o' then + return 'a'; + elsif From = 'g' then + return 't'; + else + return From; + end if; + end Dog_to_Cat_Mapping; + +end CXA40190; + + +with CXA40190; +with Report; +with Ada.Characters.Handling; +with Ada.Strings.Wide_Bounded; +with Ada.Strings.Wide_Maps; +with Ada.Strings.Wide_Maps.Wide_Constants; + +procedure CXA4019 is + + -- The following two functions are used to translate character and string + -- values to "Wide" values. They will be applied to all the Wide_Bounded + -- subprogram parameters to simulate the use of Wide_Characters and + -- Wide_Strings in actual practice. + + function Equiv (Ch : Character) return Wide_Character is + C : Character := Ch; + begin + if Ch = ' ' then + return Ada.Characters.Handling.To_Wide_Character(C); + else + return Wide_Character'Val(Character'Pos(Ch) + + Character'Pos(Character'Last) + 1); + end if; + end Equiv; + + + function Equiv (Str : String) return Wide_String is + WS : Wide_String(Str'First..Str'Last); + begin + for i in Str'First..Str'Last loop + WS(i) := Equiv(Str(i)); + end loop; + return WS; + end Equiv; + +begin + + Report.Test("CXA4019", "Check that the subprograms defined in " & + "package Ada.Strings.Wide_Bounded are " & + "available, and that they produce correct " & + "results, especially under conditions where " & + "truncation of the result is required"); + + Test_Block: + declare + + use CXA40190; + + package AS renames Ada.Strings; + package ASB renames Ada.Strings.Wide_Bounded; + package ASWC renames Ada.Strings.Wide_Maps.Wide_Constants; + package Maps renames Ada.Strings.Wide_Maps; + + package B10 is new ASB.Generic_Bounded_Length(Max => 10); + use type B10.Bounded_Wide_String; + + Result_String : B10.Bounded_Wide_String; + Test_String : B10.Bounded_Wide_String; + AtoE_Bnd_Str : B10.Bounded_Wide_String := + B10.To_Bounded_Wide_String(Equiv("abcde")); + FtoJ_Bnd_Str : B10.Bounded_Wide_String := + B10.To_Bounded_Wide_String(Equiv("fghij")); + AtoJ_Bnd_Str : B10.Bounded_Wide_String := + B10.To_Bounded_Wide_String(Equiv("abcdefghij")); + + Location : Natural := 0; + Total_Count : Natural := 0; + + CD_Set : Maps.Wide_Character_Set := Maps.To_Set("cd"); + Wide_CD_Set : Maps.Wide_Character_Set := Maps.To_Set(Equiv("cd")); + + AB_to_YZ_Map : Maps.Wide_Character_Mapping := + Maps.To_Mapping(From => "ab", To => "yz"); + + Wide_AB_to_YZ_Map : Maps.Wide_Character_Mapping := + Maps.To_Mapping(From => Equiv("ab"), + To => Equiv("yz")); + + CD_to_XY_Map : Maps.Wide_Character_Mapping := + Maps.To_Mapping(From => "cd", To => "xy"); + + Wide_CD_to_XY_Map : Maps.Wide_Character_Mapping := + Maps.To_Mapping(From => Equiv("cd"), + To => Equiv("xy")); + + + -- Access-to-Subprogram object defined for use with specific versions of + -- functions Index, Count Translate, and procedure Translate. + + Map_Ptr : Maps.Wide_Character_Mapping_Function := + Dog_to_Cat_Mapping'Access; + + + + begin + + -- Function To_Bounded_Wide_String with Truncation + -- Evaluate the function Append with parameters that will + -- cause the truncation of the result. + + -- Drop = Error (default case, Length_Error will be raised) + + begin + Test_String := + B10.To_Bounded_Wide_String + (Equiv("Much too long for this bounded wide string")); + Report.Failed("Length Error not raised by To_Bounded_Wide_String"); + exception + when AS.Length_Error => null; -- Expected exception raised. + when others => + Report.Failed + ("Incorrect exception raised by To_Bounded_Wide_String"); + end; + + -- Drop = Left + + Test_String := + B10.To_Bounded_Wide_String(Source => Equiv("abcdefghijklmn"), + Drop => Ada.Strings.Left); + + if Test_String /= B10.To_Bounded_Wide_String(Equiv("efghijklmn")) then + Report.Failed + ("Incorrect result from To_Bounded_Wide_String, Drop = Left"); + end if; + + -- Drop = Right + + Test_String := + B10.To_Bounded_Wide_String(Source => Equiv("abcdefghijklmn"), + Drop => Ada.Strings.Right); + + if not(Test_String = AtoJ_Bnd_Str) then + Report.Failed + ("Incorrect result from To_Bounded_Wide_String, Drop = Right"); + end if; + + + + + -- Function Append with Truncation + -- Evaluate the function Append with parameters that will + -- cause the truncation of the result. + + -- Drop = Error (default case, Length_Error will be raised) + + begin + -- Append (Bnd Str, Bnd Str); + Result_String := + B10.Append(B10.To_Bounded_Wide_String(Equiv("abcde")), + B10.To_Bounded_Wide_String(Equiv("fghijk"))); -- 11 char + Report.Failed("Length_Error not raised by Append - 1"); + exception + when AS.Length_Error => null; -- OK, correct exception raised. + when others => + Report.Failed("Incorrect exception raised by Append - 1"); + end; + + begin + -- Append (Str, Bnd Str); + Result_String := + B10.Append(B10.To_Wide_String(AtoE_Bnd_Str), + B10.To_Bounded_Wide_String(Equiv("fghijk")), + AS.Error); + Report.Failed("Length_Error not raised by Append - 2"); + exception + when AS.Length_Error => null; -- OK, correct exception raised. + when others => + Report.Failed("Incorrect exception raised by Append - 2"); + end; + + begin + -- Append (Bnd Str, Char); + Result_String := + B10.Append(B10.To_Bounded_Wide_String("abcdefghij"), 'k'); + Report.Failed("Length_Error not raised by Append - 3"); + exception + when AS.Length_Error => null; -- OK, correct exception raised. + when others => + Report.Failed("Incorrect exception raised by Append - 3"); + end; + + -- Drop = Left + + -- Append (Bnd Str, Bnd Str) + Result_String := + B10.Append(B10.To_Bounded_Wide_String(Equiv("abcdefgh")), -- 8 chs + B10.To_Bounded_Wide_String(Equiv("ijklmn")), -- 6 chs + Ada.Strings.Left); + + if Result_String /= + B10.To_Bounded_Wide_String(Equiv("efghijklmn")) -- 10 chars + then + Report.Failed("Incorrect truncation performed by Append - 4"); + end if; + + -- Append (Bnd Str, Str) + Result_String := + B10.Append(B10.To_Bounded_Wide_String("abcdefghij"), + "xyz", + Ada.Strings.Left); + + if Result_String /= B10.To_Bounded_Wide_String("defghijxyz") then + Report.Failed("Incorrect truncation performed by Append - 5"); + end if; + + -- Append (Char, Bnd Str) + + Result_String := + B10.Append(Equiv('A'), + B10.To_Bounded_Wide_String(Equiv("abcdefghij")), + Ada.Strings.Left); + + if Result_String /= B10.To_Bounded_Wide_String(Equiv("abcdefghij")) + then + Report.Failed("Incorrect truncation performed by Append - 6"); + end if; + + -- Drop = Right + + -- Append (Bnd Str, Bnd Str) + Result_String := B10.Append(FtoJ_Bnd_Str, + AtoJ_Bnd_Str, + Ada.Strings.Right); + + if Result_String /= + B10.To_Bounded_Wide_String(Equiv("fghijabcde")) + then + Report.Failed("Incorrect truncation performed by Append - 7"); + end if; + + -- Append (Str, Bnd Str) + Result_String := B10.Append(B10.To_Wide_String(AtoE_Bnd_Str), + AtoJ_Bnd_Str, + Ada.Strings.Right); + + if Result_String /= + B10.To_Bounded_Wide_String(Equiv("abcdeabcde")) + then + Report.Failed("Incorrect truncation performed by Append - 8"); + end if; + + -- Append (Char, Bnd Str) + Result_String := B10.Append(Equiv('A'), AtoJ_Bnd_Str, Ada.Strings.Right); + + if Result_String /= B10.To_Bounded_Wide_String(Equiv("Aabcdefghi")) then + Report.Failed("Incorrect truncation performed by Append - 9"); + end if; + + + + -- Function Index with non-Identity map. + -- Evaluate the function Index with a non-identity map + -- parameter which will cause mapping of the source parameter + -- prior to the evaluation of the index position search. + + Location := + B10.Index(Source => B10.To_Bounded_Wide_String("foxy fox 2"), + Pattern => "FOX", + Going => Ada.Strings.Backward, + Mapping => ASWC.Upper_Case_Map); + + if Location /= 6 then + Report.Failed("Incorrect result from Index, non-Identity map - 1"); + end if; + + Location := + B10.Index(B10.To_Bounded_Wide_String("THE QUICK "), + "quick", + Ada.Strings.Forward, + Ada.Strings.Wide_Maps.Wide_Constants.Lower_Case_Map); + + if Location /= 5 then + Report.Failed("Incorrect result from Index, non-Identity map - 2"); + end if; + + Location := B10.Index(Source => B10.To_Bounded_Wide_String("The the"), + Pattern => "the", + Going => Ada.Strings.Forward, + Mapping => ASWC.Lower_Case_Map); + + if Location /= 1 then + Report.Failed("Incorrect result from Index, non-Identity map - 3"); + end if; + + + + if B10.Index(B10.To_Bounded_Wide_String("abcd"), -- Pattern = Source + "abcd") /= 1 or + B10.Index(B10.To_Bounded_Wide_String("abc"), -- Pattern < Source + "abcd") /= 0 or + B10.Index(B10.Null_Bounded_Wide_String, -- Source = Null + "abc") /= 0 + then + Report.Failed("Incorrect result from Index with string patterns"); + end if; + + + + -- Function Index with access-to-subprogram mapping value. + -- Evaluate the function Index with a wide character mapping function + -- object that performs the mapping operation. + + Location := B10.Index(Source => B10.To_Bounded_Wide_String("My dog"), + Pattern => "cat", + Going => Ada.Strings.Forward, + Mapping => Map_Ptr); -- change "dog" to "cat" + + if Location /= 4 then + Report.Failed("Incorrect result from Index, w/map ptr - 1"); + end if; + + Location := B10.Index(B10.To_Bounded_Wide_String("cat or dog"), + "cat", + Ada.Strings.Backward, + Map_Ptr); + + if Location /= 8 then + Report.Failed("Incorrect result from Index, w/map ptr - 2"); + end if; + + if B10.Index(B10.To_Bounded_Wide_String("dog"), -- Pattern = Source + "cat", + Ada.Strings.Forward, + Map_Ptr) /= 1 or + B10.Index(B10.To_Bounded_Wide_String("dog"), -- Pattern < Source + "cats", + Ada.Strings.Backward, + Map_Ptr) /= 0 or + B10.Index(B10.Null_Bounded_Wide_String, -- Source = Null + "cat", + Ada.Strings.Forward, + Map_Ptr) /= 0 or + B10.Index(B10.To_Bounded_Wide_String("hot dog"), + "dog", + Ada.Strings.Backward, + Map_Ptr) /= 0 or + B10.Index(B10.To_Bounded_Wide_String(" cat dog "), + " cat", + Ada.Strings.Backward, + Map_Ptr) /= 5 or + B10.Index(B10.To_Bounded_Wide_String("dog CatDog"), + "cat", + Ada.Strings.Backward, + Map_Ptr) /= 1 or + B10.Index(B10.To_Bounded_Wide_String("CatandDog"), + "cat", + Ada.Strings.Forward, + Map_Ptr) /= 0 or + B10.Index(B10.To_Bounded_Wide_String("dddd"), + "ccccc", + Ada.Strings.Backward, + Map_Ptr) /= 0 + then + Report.Failed("Incorrect result from Index w/map ptr - 3"); + end if; + + + + -- Function Index (for Sets). + -- This version of Index uses Sets as the basis of the search. + + -- Test = Inside, Going = Forward (Default case). + Location := + B10.Index(Source => B10.To_Bounded_Wide_String(Equiv("abcdeabcde")), + Set => Wide_CD_Set, + Test => Ada.Strings.Inside, + Going => Ada.Strings.Forward); + + if not (Location = 3) then -- position of first 'c' equivalent in source. + Report.Failed("Incorrect result from Index using Sets - 1"); + end if; + + -- Test = Inside, Going = Backward. + Location := + B10.Index(Source => B10."&"(AtoE_Bnd_Str, AtoE_Bnd_Str), + Set => Wide_CD_Set, + Test => Ada.Strings.Inside, + Going => Ada.Strings.Backward); + + if not (Location = 9) then -- position of last 'd' in source. + Report.Failed("Incorrect result from Index using Sets - 2"); + end if; + + -- Test = Outside, Going = Forward. + Location := B10.Index(B10.To_Bounded_Wide_String("deddacd"), + CD_Set, + Test => Ada.Strings.Outside, + Going => Ada.Strings.Forward); + + if Location /= 2 then -- position of 'e' in source. + Report.Failed("Incorrect result from Index using Sets - 3"); + end if; + + -- Test = Outside, Going = Backward. + Location := B10.Index(B10.To_Bounded_Wide_String(Equiv("deddacd")), + Wide_CD_Set, + Ada.Strings.Outside, + Ada.Strings.Backward); + + if Location /= 5 then -- position of 'a', correct. + Report.Failed("Incorrect result from Index using Sets - 4"); + end if; + + if B10.Index(B10.To_Bounded_Wide_String("cd"), -- Source = Set + CD_Set) /= 1 or + B10.Index(B10.To_Bounded_Wide_String("c"), -- Source < Set + CD_Set) /= 1 or + B10.Index(B10.Null_Bounded_Wide_String, -- Source = Null + Wide_CD_Set) /= 0 or + B10.Index(AtoE_Bnd_Str, + Maps.To_Set('x')) /= 0 -- No match. + then + Report.Failed("Incorrect result from Index using Sets - 5"); + end if; + + + + -- Function Count with non-Identity mapping. + -- Evaluate the function Count with a non-identity map + -- parameter which will cause mapping of the source parameter + -- prior to the evaluation of the number of matching patterns. + + Total_Count := + B10.Count(Source => B10.To_Bounded_Wide_String("THE THE TH"), + Pattern => "th", + Mapping => ASWC.Lower_Case_Map); + + if Total_Count /= 3 then + Report.Failed + ("Incorrect result from function Count, non-Identity map - 1"); + end if; + + -- And a few with identity maps as well. + + if B10.Count(B10.To_Bounded_Wide_String(Equiv("ABABABABAB")), + Equiv("ABA"), + Maps.Identity) /= 2 or + B10.Count(B10.To_Bounded_Wide_String("ADCBADABCD"), + "AB", + Maps.To_Mapping("CD", "AB")) /= 5 or + B10.Count(B10.To_Bounded_Wide_String(Equiv("aaaaaaaaaa")), + Equiv("aaa")) /= 3 or + B10.Count(B10.To_Bounded_Wide_String(Equiv("XX")), + Equiv("XXX"), + Maps.Identity) /= 0 or + B10.Count(AtoE_Bnd_Str, -- Source = Pattern + Equiv("abcde")) /= 1 or + B10.Count(B10.Null_Bounded_Wide_String, -- Source = Null + " ") /= 0 + then + Report.Failed + ("Incorrect result from function Count, w,w/o mapping"); + end if; + + + + + + -- Function Count with access-to-subprogram mapping. + -- Evaluate the version function Count that uses an access-to-subprogram + -- map parameter. + + Total_Count := + B10.Count(Source => B10.To_Bounded_Wide_String("dogdogdo"), + Pattern => "ca", + Mapping => Map_Ptr); + + if Total_Count /= 3 then + Report.Failed + ("Incorrect result from function Count, w/map ptr - 1"); + end if; + + + if B10.Count(B10.To_Bounded_Wide_String("DdOoGgod"), + "c", + Map_Ptr) /= 2 or + B10.Count(B10.To_Bounded_Wide_String("dododododo"), + "do", + Map_Ptr) /= 0 or + B10.Count(B10.To_Bounded_Wide_String("Dog or dog"), + "cat", + Map_Ptr) /= 1 or + B10.Count(B10.To_Bounded_Wide_String("dddddddddd"), + "ccccc", + Map_Ptr) /= 2 or + B10.Count(B10.To_Bounded_Wide_String("do"), -- Source < Pattern + "cat", + Map_Ptr) /= 0 or + B10.Count(B10.To_Bounded_Wide_String(" dog "), -- Source = Pattern + " cat ", + Map_Ptr) /= 1 or + B10.Count(B10.Null_Bounded_Wide_String, -- Source = Null + " ", + Map_Ptr) /= 0 + then + Report.Failed + ("Incorrect result from function Count, w/map ptr - 2"); + end if; + + + + + -- Procedure Translate + + -- Partial mapping of source. + + Test_String := B10.To_Bounded_Wide_String("abcdeabcab"); + + B10.Translate(Source => Test_String, Mapping => AB_to_YZ_Map); + + if Test_String /= B10.To_Bounded_Wide_String("yzcdeyzcyz") then + Report.Failed("Incorrect result from procedure Translate - 1"); + end if; + + -- Total mapping of source. + + Test_String := B10.To_Bounded_Wide_String("abbaaababb"); + + B10.Translate(Source => Test_String, Mapping => ASWC.Upper_Case_Map); + + if Test_String /= B10.To_Bounded_Wide_String("ABBAAABABB") then + Report.Failed("Incorrect result from procedure Translate - 2"); + end if; + + -- No mapping of source. + + Test_String := B10.To_Bounded_Wide_String(Equiv("xyzsypcc")); + + B10.Translate(Source => Test_String, Mapping => Wide_AB_to_YZ_Map); + + if Test_String /= B10.To_Bounded_Wide_String(Equiv("xyzsypcc")) then + Report.Failed("Incorrect result from procedure Translate - 3"); + end if; + + -- Map > 2 characters, partial mapping. + + Test_String := B10.To_Bounded_Wide_String("opabcdelmn"); + + B10.Translate(Test_String, + Maps.To_Mapping("abcde", "lmnop")); + + if Test_String /= B10.To_Bounded_Wide_String("oplmnoplmn") then + Report.Failed("Incorrect result from procedure Translate - 4"); + end if; + + + + + -- Procedure Translate with access-to-subprogram mapping. + -- Use the version of Procedure Translate that takes an + -- access-to-subprogram parameter to perform the Source mapping. + + -- Partial mapping of source. + + Test_String := B10.To_Bounded_Wide_String("dogeatdog"); + + B10.Translate(Source => Test_String, Mapping => Map_Ptr); + + if Test_String /= B10.To_Bounded_Wide_String("cateatcat") then + Report.Failed + ("Incorrect result from procedure Translate w/map ptr - 1"); + end if; + + Test_String := B10.To_Bounded_Wide_String("odogcatlmn"); + + B10.Translate(Test_String, Map_Ptr); + + if Test_String /= B10.To_Bounded_Wide_String("acatcatlmn") then + Report.Failed + ("Incorrect result from procedure Translate w/map ptr - 2"); + end if; + + + -- Total mapping of source. + + Test_String := B10.To_Bounded_Wide_String("gggooooddd"); + + B10.Translate(Source => Test_String, Mapping => Map_Ptr); + + if Test_String /= B10.To_Bounded_Wide_String("tttaaaaccc") then + Report.Failed + ("Incorrect result from procedure Translate w/map ptr- 3"); + end if; + + -- No mapping of source. + + Test_String := B10.To_Bounded_Wide_String(" DOG cat "); + + B10.Translate(Source => Test_String, Mapping => Map_Ptr); + + if Test_String /= B10.To_Bounded_Wide_String(" DOG cat ") then + Report.Failed + ("Incorrect result from procedure Translate w/map ptr - 4"); + end if; + + Test_String := B10.Null_Bounded_Wide_String; + + B10.Translate(Source => Test_String, Mapping => Map_Ptr); + + if Test_String /= B10.To_Bounded_Wide_String("") then + Report.Failed + ("Incorrect result from procedure Translate w/map ptr - 5"); + end if; + + + + + -- Function Translate with access-to-subprogram mapping. + -- Use the version of Function Translate that takes an + -- access-to-subprogram parameter to perform the Source mapping. + + -- Partial mapping of source. + + if B10.Translate(Source => B10.To_Bounded_Wide_String("cateatdog"), + Mapping => Map_Ptr) /= + B10.To_Bounded_Wide_String("cateatcat") + then + Report.Failed + ("Incorrect result from function Translate w/map ptr - 1"); + end if; + + if B10.Translate(B10.To_Bounded_Wide_String("cadogtac"), + Map_Ptr) /= + B10.To_Bounded_Wide_String("cacattac") + then + Report.Failed + ("Incorrect result from function Translate w/map ptr - 2"); + end if; + + -- Total mapping of source. + + if B10.Translate(Source => B10.To_Bounded_Wide_String("dogodggdo"), + Mapping => Map_Ptr) /= + B10.To_Bounded_Wide_String("catacttca") + then + Report.Failed + ("Incorrect result from function Translate w/map ptr- 3"); + end if; + + -- No mapping of source. + + if B10.Translate(Source => B10.To_Bounded_Wide_String(" DOG cat "), + Mapping => Map_Ptr) /= + B10.To_Bounded_Wide_String(" DOG cat ") + then + Report.Failed + ("Incorrect result from function Translate w/map ptr - 4"); + end if; + + if B10.Translate(B10.To_Bounded_Wide_String("d "), Map_Ptr) /= + B10.To_Bounded_Wide_String("c ") or + B10.Translate(B10.To_Bounded_Wide_String(" god"), Map_Ptr) /= + B10.To_Bounded_Wide_String(" tac") or + B10.Translate(B10.To_Bounded_Wide_String("d o g D og"), Map_Ptr) /= + B10.To_Bounded_Wide_String("c a t D at") or + B10.Translate(B10.To_Bounded_Wide_String(" "), Map_Ptr) /= + B10.To_Bounded_Wide_String(" ") or + B10.Translate(B10.To_Bounded_Wide_String("dddddddddd"), Map_Ptr) /= + B10.To_Bounded_Wide_String("cccccccccc") + then + Report.Failed + ("Incorrect result from function Translate w/map ptr - 5"); + end if; + + if B10.Translate(Source => B10.Null_Bounded_Wide_String, + Mapping => Map_Ptr) /= + B10.To_Bounded_Wide_String("") + then + Report.Failed + ("Incorrect result from function Translate w/map ptr - 6"); + end if; + + + + + -- Function Replace_Slice + -- Evaluate function Replace_Slice with + -- a variety of Truncation options. + + -- Drop = Error (Default) + + begin + Test_String := AtoJ_Bnd_Str; + Result_String := + B10.Replace_Slice(Source => Test_String, + Low => 3, + High => 5, -- 3-5, 3 chars. + By => Equiv("xxxxxx")); -- more than 3. + Report.Failed("Length_Error not raised by Function Replace_Slice"); + exception + when AS.Length_Error => null; -- Correct exception raised. + when others => + Report.Failed + ("Incorrect exception raised by Function Replace_Slice"); + end; + + -- Drop = Left + + Result_String := + B10.Replace_Slice(Source => Test_String, + Low => 7, + High => 10, -- 7-10, 4 chars. + By => Equiv("xxxxxx"), -- 6 chars. + Drop => Ada.Strings.Left); + + if Result_String /= + B10.To_Bounded_Wide_String(Equiv("cdefxxxxxx")) -- drop a,b + then + Report.Failed + ("Incorrect result from Function Replace Slice, Drop = Left"); + end if; + + -- Drop = Right + + Result_String := + B10.Replace_Slice(Source => Test_String, + Low => 2, + High => 5, -- 2-5, 4 chars. + By => Equiv("xxxxxx"), -- 6 chars. + Drop => Ada.Strings.Right); + + if Result_String /= + B10.To_Bounded_Wide_String(Equiv("axxxxxxfgh")) -- drop i,j + then + Report.Failed + ("Incorrect result from Function Replace Slice, Drop = Right"); + end if; + + -- Low = High = Source'Last, "By" length = 1. + + if B10.Replace_Slice(AtoE_Bnd_Str, + B10.To_Wide_String(AtoE_Bnd_Str)'Last, + B10.To_Wide_String(AtoE_Bnd_Str)'Last, + Equiv("X"), + Ada.Strings.Error) /= + B10.To_Bounded_Wide_String(Equiv("abcdX")) + then + Report.Failed("Incorrect result from Function Replace_Slice"); + end if; + + -- Index_Error raised when High < Source'First - 1. + begin + Test_String := + B10.Replace_Slice(AtoE_Bnd_Str, + B10.To_Wide_String(AtoE_Bnd_Str)'First, + B10.To_Wide_String(AtoE_Bnd_Str)'First - 2, + Equiv("hijklm")); + Report.Failed("Index_Error not raised by Function Replace_Slice"); + exception + when AS.Index_Error => null; -- OK, expected exception + when Constraint_Error => null; -- Also OK, since RM is not clear + when others => + Report.Failed + ("Incorrect exception raised by Function Replace_Slice"); + end; + + + + -- Procedure Replace_Slice + -- Evaluate procedure Replace_Slice with + -- a variety of Truncation options. + + -- Drop = Error (Default) + + begin + Test_String := AtoJ_Bnd_Str; + B10.Replace_Slice(Source => Test_String, + Low => 3, + High => 5, -- 3-5, 3 chars. + By => Equiv("xxxxxx")); -- more than 3. + Report.Failed("Length_Error not raised by Procedure Replace_Slice"); + exception + when AS.Length_Error => null; -- Correct exception raised. + when others => + Report.Failed + ("Incorrect exception raised by Procedure Replace_Slice"); + end; + + -- Drop = Left + + Test_String := AtoJ_Bnd_Str; + B10.Replace_Slice(Source => Test_String, + Low => 7, + High => 9, -- 7-9, 3 chars. + By => Equiv("xxxxx"), -- 5 chars. + Drop => Ada.Strings.Left); + + if Test_String /= + B10.To_Bounded_Wide_String(Equiv("cdefxxxxxj")) -- drop a,b + then + Report.Failed + ("Incorrect result from Procedure Replace Slice, Drop = Left"); + end if; + + -- Drop = Right + + Test_String := AtoJ_Bnd_Str; + B10.Replace_Slice(Source => Test_String, + Low => 1, + High => 3, -- 1-3, 3chars. + By => Equiv("xxxx"), -- 4 chars. + Drop => Ada.Strings.Right); + + if Test_String /= + B10.To_Bounded_Wide_String(Equiv("xxxxdefghi")) -- drop j + then + Report.Failed + ("Incorrect result from Procedure Replace Slice, Drop = Right"); + end if; + + -- High = Source'First, Low > High (Insert before Low). + + Test_String := AtoE_Bnd_Str; + B10.Replace_Slice(Source => Test_String, + Low => B10.To_Wide_String(Test_String)'Last, + High => B10.To_Wide_String(Test_String)'First, + By => Equiv("XXXX"), -- 4 chars. + Drop => Ada.Strings.Right); + + if Test_String /= B10.To_Bounded_Wide_String(Equiv("abcdXXXXe")) then + Report.Failed + ("Incorrect result from Procedure Replace Slice"); + end if; + + + + + -- Function Insert with Truncation + -- Drop = Error (Default). + + begin + Result_String := + B10.Insert(Source => AtoJ_Bnd_Str, -- "abcdefghij" + Before => 2, + New_Item => Equiv("xyz")); + Report.Failed("Length_Error not raised by Function Insert"); + exception + when AS.Length_Error => null; -- Correct exception raised. + when others => + Report.Failed("Incorrect exception raised by Function Insert"); + end; + + -- Drop = Left + + Result_String := + B10.Insert(Source => AtoJ_Bnd_Str, -- "abcdefghij" + Before => 5, + New_Item => Equiv("xyz"), -- 3 additional chars. + Drop => Ada.Strings.Left); + + if B10.To_Wide_String(Result_String) /= Equiv("dxyzefghij") then + Report.Failed("Incorrect result from Function Insert, Drop = Left"); + end if; + + -- Drop = Right + + Result_String := + B10.Insert(Source => B10.To_Bounded_Wide_String("abcdef"), + Before => 2, + New_Item => "vwxyz", -- 5 additional chars. + Drop => Ada.Strings.Right); + + if B10.To_Wide_String(Result_String) /= "avwxyzbcde" then -- drop f. + Report.Failed("Incorrect result from Function Insert, Drop = Right"); + end if; + + -- Additional cases. + + if B10.Insert(B10.To_Bounded_Wide_String("a"), 1, " B") /= + B10.To_Bounded_Wide_String(" Ba") or + B10.Insert(B10.Null_Bounded_Wide_String, 1, Equiv("abcde")) /= + AtoE_Bnd_Str or + B10.Insert(B10.To_Bounded_Wide_String("ab"), 2, "") /= + B10.To_Bounded_Wide_String("ab") + then + Report.Failed("Incorrect result from Function Insert"); + end if; + + + + -- Procedure Insert + + -- Drop = Error (Default). + begin + Test_String := AtoJ_Bnd_Str; + B10.Insert(Source => Test_String, + Before => 9, + New_Item => Equiv("wxyz"), + Drop => Ada.Strings.Error); + Report.Failed("Length_Error not raised by Procedure Insert"); + exception + when AS.Length_Error => null; -- Correct exception raised. + when others => + Report.Failed("Incorrect exception raised by Procedure Insert"); + end; + + -- Drop = Left + + Test_String := AtoJ_Bnd_Str; + B10.Insert(Source => Test_String, + Before => B10.Length(Test_String), -- before last char + New_Item => Equiv("xyz"), -- 3 additional chars. + Drop => Ada.Strings.Left); + + if B10.To_Wide_String(Test_String) /= Equiv("defghixyzj") then + Report.Failed("Incorrect result from Procedure Insert, Drop = Left"); + end if; + + -- Drop = Right + + Test_String := AtoJ_Bnd_Str; + B10.Insert(Source => Test_String, + Before => 4, + New_Item => Equiv("yz"), -- 2 additional chars. + Drop => Ada.Strings.Right); + + if B10.To_Wide_String(Test_String) /= Equiv("abcyzdefgh") then + Report.Failed + ("Incorrect result from Procedure Insert, Drop = Right"); + end if; + + -- Before = Source'First, New_Item length = 1. + + Test_String := B10.To_Bounded_Wide_String(" abc "); + B10.Insert(Test_String, + B10.To_Wide_String(Test_String)'First, + "Z"); + + if Test_String /= B10.To_Bounded_Wide_String("Z abc ") then + Report.Failed("Incorrect result from Procedure Insert"); + end if; + + + exception + when others => Report.Failed("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + +end CXA4019; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4020.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4020.a new file mode 100644 index 000000000..24036f171 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4020.a @@ -0,0 +1,688 @@ +-- CXA4020.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 subprograms defined in package Ada.Strings.Wide_Bounded +-- are available, and that they produce correct results, especially under +-- conditions where truncation of the result is required. Specifically, +-- check the subprograms Overwrite (function and procedure), Delete, +-- Function Trim (blanks), Trim (Set wide characters, function and +-- procedure), Head, Tail, and Replicate (wide characters and wide +-- strings). +-- +-- TEST DESCRIPTION: +-- This test, in conjunction with tests CXA4017, CXA4018, CXA4019, +-- will provide coverage of the most common usages of the functionality +-- found in the Ada.Strings.Wide_Bounded package. It deals in large part +-- with truncation effects and options. This test contains many small, +-- specific test cases, situations that are often difficult to generate +-- in large numbers in an application-based test. These cases represent +-- specific usage paradigms in-the-small. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 22 Dec 94 SAIC Changed obsolete constant to Strings.Wide_Space. +-- 13 Apr 95 SAIC Corrected certain subtest acceptance conditions. +-- +--! + +with Report; +with Ada.Characters.Handling; +with Ada.Strings.Wide_Bounded; +with Ada.Strings.Wide_Maps; + +procedure CXA4020 is + + -- The following two functions are used to translate character and string + -- values to "Wide" values. They will be applied to all the Wide_Bounded + -- subprogram parameters to simulate the use of Wide_Characters and + -- Wide_Strings in actual practice. Blanks are translated to Wide_Character + -- blanks and all other characters are translated into Wide_Characters with + -- position values 256 greater than their (narrow) character position + -- values. + + function Translate (Ch : Character) return Wide_Character is + C : Character := Ch; + begin + if Ch = ' ' then + return Ada.Characters.Handling.To_Wide_Character(C); + else + return Wide_Character'Val(Character'Pos(Ch) + + Character'Pos(Character'Last) + 1); + end if; + end Translate; + + + function Translate (Str : String) return Wide_String is + WS : Wide_String(Str'First..Str'Last); + begin + for i in Str'First..Str'Last loop + WS(i) := Translate(Str(i)); + end loop; + return WS; + end Translate; + + +begin + + Report.Test("CXA4020", "Check that the subprograms defined in " & + "package Ada.Strings.Wide_Bounded are " & + "available, and that they produce correct " & + "results, especially under conditions where " & + "truncation of the result is required"); + + Test_Block: + declare + + package AS renames Ada.Strings; + package ASW renames Ada.Strings.Wide_Bounded; + package Maps renames Ada.Strings.Wide_Maps; + + package B10 is new ASW.Generic_Bounded_Length(Max => 10); + use type B10.Bounded_Wide_String; + + Result_String : B10.Bounded_Wide_String; + Test_String : B10.Bounded_Wide_String; + AtoE_Bnd_Str : B10.Bounded_Wide_String := + B10.To_Bounded_Wide_String(Translate("abcde")); + FtoJ_Bnd_Str : B10.Bounded_Wide_String := + B10.To_Bounded_Wide_String(Translate("fghij")); + AtoJ_Bnd_Str : B10.Bounded_Wide_String := + B10.To_Bounded_Wide_String(Translate("abcdefghij")); + + Location : Natural := 0; + Total_Count : Natural := 0; + + CD_Set : Maps.Wide_Character_Set := Maps.To_Set(Translate("cd")); + XY_Set : Maps.Wide_Character_Set := Maps.To_Set(Translate("xy")); + + + begin + + -- Function Overwrite with Truncation + -- Drop = Error (Default). + + begin + Test_String := AtoJ_Bnd_Str; + Result_String := + B10.Overwrite(Source => Test_String, -- "abcdefghij" + Position => 9, + New_Item => Translate("xyz"), + Drop => AS.Error); + Report.Failed("Exception not raised by Function Overwrite"); + exception + when AS.Length_Error => null; -- Expected exception raised. + when others => + Report.Failed("Incorrect exception raised by Function Overwrite"); + end; + + -- Drop = Left + + Result_String := + B10.Overwrite(Source => Test_String, -- "abcdefghij" + Position => B10.Length(Test_String), -- 10 + New_Item => Translate("xyz"), + Drop => Ada.Strings.Left); + + if B10.To_Wide_String(Result_String) /= + Translate("cdefghixyz") then -- drop a,b + Report.Failed + ("Incorrect result from Function Overwrite, Drop = Left"); + end if; + + -- Drop = Right + + Result_String := B10.Overwrite(Test_String, -- "abcdefghij" + 3, + Translate("xxxyyyzzz"), + Ada.Strings.Right); + + if B10.To_Wide_String(Result_String) /= + Translate("abxxxyyyzz") + then + Report.Failed + ("Incorrect result from Function Overwrite, Drop = Right"); + end if; + + -- Additional cases of function Overwrite. + + if B10.Overwrite(B10.To_Bounded_Wide_String(Translate("a")), + 1, -- Source length = 1 + Translate(" abc ")) /= + B10.To_Bounded_Wide_String(Translate(" abc ")) or + B10.Overwrite(B10.Null_Bounded_Wide_String, -- Null source + 1, + Translate("abcdefghij")) /= + AtoJ_Bnd_Str or + B10.Overwrite(AtoE_Bnd_Str, + B10.To_Wide_String(AtoE_Bnd_Str)'First, + Translate(" ")) /= -- New_Item = 1 + B10.To_Bounded_Wide_String(Translate(" bcde")) + then + Report.Failed("Incorrect result from Function Overwrite"); + end if; + + + + -- Procedure Overwrite + -- Correct usage, no truncation. + + Test_String := AtoE_Bnd_Str; -- "abcde" + B10.Overwrite(Test_String, 2, Translate("xyz")); + + if Test_String /= B10.To_Bounded_Wide_String(Translate("axyze")) then + Report.Failed("Incorrect result from Procedure Overwrite - 1"); + end if; + + Test_String := B10.To_Bounded_Wide_String(Translate("abc")); + B10.Overwrite(Test_String, 2, ""); -- New_Item is null string. + + if Test_String /= B10.To_Bounded_Wide_String(Translate("abc")) then + Report.Failed("Incorrect result from Procedure Overwrite - 2"); + end if; + + -- Drop = Error (Default). + + begin + Test_String := AtoJ_Bnd_Str; + B10.Overwrite(Source => Test_String, -- "abcdefghij" + Position => 8, + New_Item => Translate("uvwxyz")); + Report.Failed("Exception not raised by Procedure Overwrite"); + exception + when AS.Length_Error => null; -- Expected exception raised. + when others => + Report.Failed("Incorrect exception raised by Procedure Overwrite"); + end; + + -- Drop = Left + + Test_String := AtoJ_Bnd_Str; + B10.Overwrite(Source => Test_String, -- "abcdefghij" + Position => B10.Length(Test_String) - 2, -- 8 + New_Item => Translate("uvwxyz"), + Drop => Ada.Strings.Left); + + if B10.To_Wide_String(Test_String) /= + Translate("defguvwxyz") + then + Report.Failed + ("Incorrect result from Procedure Overwrite, Drop = Left"); + end if; + + -- Drop = Right + + Test_String := AtoJ_Bnd_Str; + B10.Overwrite(Test_String, -- "abcdefghij" + 3, + Translate("xxxyyyzzz"), + Ada.Strings.Right); + + if B10.To_Wide_String(Test_String) /= Translate("abxxxyyyzz") then + Report.Failed + ("Incorrect result from Procedure Overwrite, Drop = Right"); + end if; + + + + -- Function Delete + + if B10.Delete(Source => AtoJ_Bnd_Str, -- "abcdefghij" + From => 3, + Through => 8) /= + B10."&"(B10.Head(AtoJ_Bnd_Str, 2), + B10.Tail(AtoJ_Bnd_Str, 2)) or + B10.Delete(AtoJ_Bnd_Str, 6, B10.Length(AtoJ_Bnd_Str)) /= + AtoE_Bnd_Str or + B10.Delete(AtoJ_Bnd_Str, 1, 5) /= + FtoJ_Bnd_Str + then + Report.Failed("Incorrect result from Function Delete - 1"); + end if; + + if B10.Delete(B10.To_Bounded_Wide_String(Translate("a")), 1, 1) /= + B10.Null_Bounded_Wide_String or + B10.Delete(AtoE_Bnd_Str, + 5, + B10.To_Wide_String(AtoE_Bnd_Str)'First) /= + AtoE_Bnd_Str or + B10.Delete(AtoE_Bnd_Str, + B10.To_Wide_String(AtoE_Bnd_Str)'Last, + B10.To_Wide_String(AtoE_Bnd_Str)'Last) /= + B10.To_Bounded_Wide_String(Translate("abcd")) + then + Report.Failed("Incorrect result from Function Delete - 2"); + end if; + + + + -- Function Trim + + declare + + Text : B10.Bounded_Wide_String := + B10.To_Bounded_Wide_String(Translate("Text")); + type Bnd_Array_Type is array (1..5) of B10.Bounded_Wide_String; + Bnd_Array : Bnd_Array_Type := + (B10.To_Bounded_Wide_String(Translate(" Text")), + B10.To_Bounded_Wide_String(Translate("Text ")), + B10.To_Bounded_Wide_String(Translate(" Text ")), + B10.To_Bounded_Wide_String(Translate("Text Text")), + B10.To_Bounded_Wide_String(Translate(" Text Text"))); + + begin + + for i in Bnd_Array_Type'Range loop + case i is + when 4 => + if B10.Trim(Bnd_Array(i), AS.Both) /= + Bnd_Array(i) then -- no change + Report.Failed("Incorrect result from Function Trim - 4"); + end if; + when 5 => + if B10.Trim(Bnd_Array(i), AS.Both) /= + B10."&"(Text, B10."&"(Translate(' '), Text)) + then + Report.Failed("Incorrect result from Function Trim - 5"); + end if; + when others => + if B10.Trim(Bnd_Array(i), AS.Both) /= Text then + Report.Failed("Incorrect result from Function Trim - " & + Integer'Image(i)); + end if; + end case; + end loop; + + end; + + + + -- Function Trim using Sets + + -- Trim characters in sets from both sides of the bounded wide string. + if B10.Trim(Source => B10.To_Bounded_Wide_String(Translate("ddabbaxx")), + Left => CD_Set, + Right => XY_Set) /= + B10.To_Bounded_Wide_String(Translate("abba")) + then + Report.Failed + ("Incorrect result from Fn Trim - Sets, Left & Right side - 1"); + end if; + + -- Ensure that the characters in the set provided as the actual to + -- parameter Right are not trimmed from the left side of the bounded + -- wide string; likewise for the opposite side. Only "cd" trimmed + -- from left side, and only "xy" trimmed from right side. + + if B10.Trim(B10.To_Bounded_Wide_String(Translate("cdxyabcdxy")), + CD_Set, + XY_Set) /= + B10.To_Bounded_Wide_String(Translate("xyabcd")) + then + Report.Failed + ("Incorrect result from Fn Trim - Sets, Left & Right side - 2"); + end if; + + -- Ensure that characters contained in the sets are not trimmed from + -- the "interior" of the bounded wide string, just the appropriate ends. + + if B10.Trim(B10.To_Bounded_Wide_String(Translate("cdabdxabxy")), + CD_Set, + XY_Set) /= + B10.To_Bounded_Wide_String(Translate("abdxab")) + then + Report.Failed + ("Incorrect result from Fn Trim - Sets, Left & Right side - 3"); + end if; + + -- Trim characters in set from right side only. No change to Left side. + + if B10.Trim(B10.To_Bounded_Wide_String(Translate("abxyzddcd")), + XY_Set, + CD_Set) /= + B10.To_Bounded_Wide_String(Translate("abxyz")) + then + Report.Failed + ("Incorrect result from Fn Trim - Sets, Right side"); + end if; + + -- Trim no characters on either side of the bounded string. + + Result_String := B10.Trim(AtoJ_Bnd_Str, CD_Set, XY_Set); + if Result_String /= AtoJ_Bnd_Str then + Report.Failed("Incorrect result from Fn Trim - Sets, Neither side"); + end if; + + if B10.Trim(AtoE_Bnd_Str, Maps.Null_Set, Maps.Null_Set) /= + AtoE_Bnd_Str or + B10.Trim(B10.To_Bounded_Wide_String(Translate("dcddcxyyxx")), + CD_Set, + XY_Set) /= + B10.Null_Bounded_Wide_String + then + Report.Failed("Incorrect result from Function Trim"); + end if; + + + + -- Procedure Trim using Sets + + -- Trim characters in sets from both sides of the bounded wide string. + + Test_String := B10.To_Bounded_Wide_String(Translate("dcabbayx")); + B10.Trim(Source => Test_String, + Left => CD_Set, + Right => XY_Set); + + if Test_String /= B10.To_Bounded_Wide_String(Translate("abba")) then + Report.Failed + ("Incorrect result from Proc Trim - Sets, Left & Right side - 1"); + end if; + + -- Ensure that the characters in the set provided as the actual to + -- parameter Right are not trimmed from the left side of the bounded + -- wide string; likewise for the opposite side. Only "cd" trimmed + -- from left side, and only "xy" trimmed from right side. + + Test_String := B10.To_Bounded_Wide_String(Translate("cdxyabcdxy")); + B10.Trim(Test_String, CD_Set, XY_Set); + + if Test_String /= B10.To_Bounded_Wide_String(Translate("xyabcd")) then + Report.Failed + ("Incorrect result from Proc Trim - Sets, Left & Right side - 2"); + end if; + + -- Ensure that characters contained in the sets are not trimmed from + -- the "interior" of the bounded wide string, just the appropriate ends. + + Test_String := B10.To_Bounded_Wide_String(Translate("cdabdxabxy")); + B10.Trim(Test_String, CD_Set, XY_Set); + + if not + (Test_String = B10.To_Bounded_Wide_String(Translate("abdxab"))) then + Report.Failed + ("Incorrect result from Proc Trim - Sets, Left & Right side - 3"); + end if; + + -- Trim characters in set from Left side only. No change to Right side. + + Test_String := B10.To_Bounded_Wide_String(Translate("cccdabxyz")); + B10.Trim(Test_String, CD_Set, XY_Set); + + if Test_String /= B10.To_Bounded_Wide_String(Translate("abxyz")) then + Report.Failed + ("Incorrect result from Proc Trim for Sets, Left side only"); + end if; + + -- Trim no characters on either side of the bounded wide string. + + Test_String := AtoJ_Bnd_Str; + B10.Trim(Test_String, CD_Set, CD_Set); + + if Test_String /= AtoJ_Bnd_Str then + Report.Failed("Incorrect result from Proc Trim-Sets, Neither side"); + end if; + + + + -- Function Head with Truncation + -- Drop = Error (Default). + + begin + Result_String := B10.Head(Source => AtoJ_Bnd_Str, -- max length + Count => B10.Length(AtoJ_Bnd_Str) + 1, + Pad => Translate('X')); + Report.Failed("Length_Error not raised by Function Head"); + exception + when AS.Length_Error => null; -- Expected exception raised. + when others => + Report.Failed("Incorrect exception raised by Function Head"); + end; + + -- Drop = Left + + -- Pad characters (5) are appended to the right end of the bounded + -- wide string (which is initially at its maximum length), then the + -- first five characters of the intermediate result are dropped to + -- conform to the maximum size limit of the bounded wide string (10). + + Result_String := + B10.Head(B10.To_Bounded_Wide_String(Translate("ABCDEFGHIJ")), + 15, + Translate('x'), + Ada.Strings.Left); + + if Result_String /= + B10.To_Bounded_Wide_String(Translate("FGHIJxxxxx")) + then + Report.Failed("Incorrect result from Function Head, Drop = Left"); + end if; + + -- Drop = Right + + -- Pad characters (6) are appended to the left end of the bounded + -- wide string (which is initially at one less than its maximum length), + -- then the last five characters of the intermediate result are dropped + -- (which in this case are the pad characters) to conform to the + -- maximum size limit of the bounded wide string (10). + + Result_String := + B10.Head(B10.To_Bounded_Wide_String(Translate("ABCDEFGHI")), + 15, + Translate('x'), + Ada.Strings.Right); + + if Result_String /= + B10.To_Bounded_Wide_String(Translate("ABCDEFGHIx")) + then + Report.Failed("Incorrect result from Function Head, Drop = Right"); + end if; + + -- Additional cases. + + if B10.Head(B10.Null_Bounded_Wide_String, 5, Translate('a')) /= + B10.To_Bounded_Wide_String(Translate("aaaaa")) or + B10.Head(AtoE_Bnd_Str, + B10.Length(AtoE_Bnd_Str)) /= + AtoE_Bnd_Str + then + Report.Failed("Incorrect result from Function Head"); + end if; + + + + -- Function Tail with Truncation + -- Drop = Error (Default Case) + + begin + Result_String := B10.Tail(Source => AtoJ_Bnd_Str, -- max length + Count => B10.Length(AtoJ_Bnd_Str) + 1, + Pad => Ada.Strings.Wide_Space, + Drop => Ada.Strings.Error); + Report.Failed("Length_Error not raised by Function Tail"); + exception + when AS.Length_Error => null; -- Expected exception raised. + when others => + Report.Failed("Incorrect exception raised by Function Tail"); + end; + + -- Drop = Left + + -- Pad characters (5) are appended to the left end of the bounded wide + -- string (which is initially at two less than its maximum length), + -- then the first three characters of the intermediate result (in this + -- case, 3 pad characters) are dropped. + + Result_String := + B10.Tail(B10.To_Bounded_Wide_String(Translate("ABCDEFGH")), + 13, + Translate('x'), + Ada.Strings.Left); + + if Result_String /= + B10.To_Bounded_Wide_String(Translate("xxABCDEFGH")) + then + Report.Failed("Incorrect result from Function Tail, Drop = Left"); + end if; + + -- Drop = Right + + -- Pad characters (3) are appended to the left end of the bounded wide + -- string (which is initially at its maximum length), then the last + -- three characters of the intermediate result are dropped. + + Result_String := + B10.Tail(B10.To_Bounded_Wide_String(Translate("ABCDEFGHIJ")), + 13, + Translate('x'), + Ada.Strings.Right); + + if Result_String /= + B10.To_Bounded_Wide_String(Translate("xxxABCDEFG")) + then + Report.Failed("Incorrect result from Function Tail, Drop = Right"); + end if; + + -- Additional cases. + + if B10.Tail(B10.Null_Bounded_Wide_String, 3, Translate(' ')) /= + B10.To_Bounded_Wide_String(Translate(" ")) or + B10.Tail(AtoE_Bnd_Str, + B10.To_Wide_String(AtoE_Bnd_Str)'First) /= + B10.To_Bounded_Wide_String(Translate("e")) + then + Report.Failed("Incorrect result from Function Tail"); + end if; + + + + -- Function Replicate (#, Char) with Truncation + -- Drop = Error (Default). + + begin + Result_String := B10.Replicate(Count => B10.Max_Length + 5, + Item => Translate('A'), + Drop => AS.Error); + Report.Failed + ("Length_Error not raised by Replicate for characters"); + exception + when AS.Length_Error => null; -- Expected exception raised. + when others => + Report.Failed + ("Incorrect exception raised by Replicate for characters"); + end; + + -- Drop = Left, Right + -- Since this version of Replicate uses wide character parameters, the + -- result after truncation from left or right will appear the same. + -- The result will be a 10 character bounded wide string, composed of + -- 10 "Item" wide characters. + + if B10.Replicate(Count => 20, + Item => Translate('A'), + Drop => Ada.Strings.Left) /= + B10.Replicate(15, Translate('A'), Ada.Strings.Right) + then + Report.Failed("Incorrect result from Replicate for characters - 1"); + end if; + + -- Blank-filled, 10 character bounded wide strings. + + if B10.Replicate(B10.Max_Length + 1, + Translate(' '), + Drop => Ada.Strings.Left) /= + B10.Replicate(B10.Max_Length, Ada.Strings.Wide_Space) + then + Report.Failed("Incorrect result from Replicate for characters - 2"); + end if; + + -- Additional cases. + + if B10.Replicate(0, Translate('a')) /= B10.Null_Bounded_Wide_String or + B10.Replicate(1, Translate('a')) /= + B10.To_Bounded_Wide_String(Translate("a")) + then + Report.Failed("Incorrect result from Replicate for characters - 3"); + end if; + + + + -- Function Replicate (#, String) with Truncation + -- Drop = Error (Default). + + begin + Result_String := B10.Replicate(Count => 5, -- result would be 15. + Item => Translate("abc")); + Report.Failed + ("Length_Error not raised by Replicate for wide strings"); + exception + when AS.Length_Error => null; -- Expected exception raised. + when others => + Report.Failed + ("Incorrect exception raised by Replicate for wide strings"); + end; + + -- Drop = Left + + Result_String := B10.Replicate(3, Translate("abcd"), Ada.Strings.Left); + + if Result_String /= + B10.To_Bounded_Wide_String(Translate("cdabcdabcd")) + then + Report.Failed + ("Incorrect result from Replicate for wide strings, Drop = Left"); + end if; + + -- Drop = Right + + Result_String := B10.Replicate(3, Translate("abcd"), Ada.Strings.Right); + + if Result_String /= + B10.To_Bounded_Wide_String(Translate("abcdabcdab")) then + Report.Failed + ("Incorrect result from Replicate for wide strings, Drop = Right"); + end if; + + -- Additional cases. + + if B10.Replicate(5, Translate("X")) /= + B10.To_Bounded_Wide_String(Translate("XXXXX")) or + B10.Replicate(10, "") /= + B10.Null_Bounded_Wide_String or + B10.Replicate(0, Translate("ab")) /= + B10.Null_Bounded_Wide_String + then + Report.Failed("Incorrect result from Replicate for wide strings"); + end if; + + + exception + when others => Report.Failed("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + +end CXA4020; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4021.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4021.a new file mode 100644 index 000000000..345a77c68 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4021.a @@ -0,0 +1,311 @@ +-- CXA4021.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 subprograms defined in package +-- Ada.Strings.Wide_Unbounded are available, and that they produce +-- correct results. Specifically, check the subprograms Head, Index, +-- Index_Non_Blank, Insert, Length, Overwrite, Replace_Slice, Slice, +-- Tail, To_Wide_String, To_Unbounded_Wide_String, "*", "&", +-- and "=", "<=", ">=". +-- +-- TEST DESCRIPTION: +-- This test demonstrates the uses of many of the subprograms defined +-- in package Ada.Strings.Wide_Unbounded for use with unbounded wide +-- strings. +-- The test attempts to simulate how unbounded wide strings could be used +-- to simulate paragraphs of text. Modifications could be easily be +-- performed using the provided subprograms (although in this test, the +-- main modification performed was the addition of more text to the +-- string). One would not have to worry about the formatting of the +-- paragraph until it was finished and correct in content. Then, once +-- all required editing is complete, the unbounded strings can be divided +-- up into the appropriate lengths based on particular formatting +-- requirements. The test then compares the formatted text product +-- with a predefined "finished product". +-- +-- This test attempts to use a large number of the subprograms provided +-- by package Ada.Strings.Wide_Unbounded. Often, the processing involved +-- could have been performed more efficiently using a minimum number +-- of the subprograms, in conjunction with loops, etc. However, for +-- testing purposes, and in the interest of minimizing the number of +-- tests developed, subprogram variety and feature mixing was stressed. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +with Report; +with Ada.Characters.Handling; +with Ada.Strings.Wide_Maps; +with Ada.Strings.Wide_Unbounded; + +procedure CXA4021 is + + -- The following two functions are used to translate character and string + -- values to "Wide" values. They will be applied to all the Wide_Bounded + -- subprogram character and string parameters to simulate the use of non- + -- character Wide_Characters and Wide_Strings in actual practice. + -- Note: These functions do not actually return "equivalent" wide + -- characters to their character inputs, just "non-character" + -- wide characters. + + function Equiv (Ch : Character) return Wide_Character is + C : Character := Ch; + begin + if Ch = ' ' then + return Ada.Characters.Handling.To_Wide_Character(C); + else + return Wide_Character'Val(Character'Pos(Ch) + + Character'Pos(Character'Last) + 1); + end if; + end Equiv; + + + function Equiv (Str : String) return Wide_String is + WS : Wide_String(Str'First..Str'Last); + begin + for i in Str'First..Str'Last loop + WS(i) := Equiv(Str(i)); + end loop; + return WS; + end Equiv; + +begin + + Report.Test ("CXA4021", "Check that the subprograms defined in " & + "package Ada.Strings.Wide_Unbounded are " & + "available, and that they produce correct " & + "results"); + + Test_Block: + declare + + package ASW renames Ada.Strings.Wide_Unbounded; + use type ASW.Unbounded_Wide_String; + use Ada.Strings; + + Pamphlet_Paragraph_Count : constant := 2; + Lines : constant := 4; + Line_Length : constant := 40; + + type Document_Type is array (Positive range <>) + of ASW.Unbounded_Wide_String; + + type Camera_Ready_Copy_Type is array (1..Lines) + of Wide_String (1..Line_Length); + + Pamphlet : Document_Type (1..Pamphlet_Paragraph_Count); + + Camera_Ready_Copy : Camera_Ready_Copy_Type := + (others => (others => Ada.Strings.Wide_Space)); + + TC_Finished_Product : Camera_Ready_Copy_Type := + ( 1 => Equiv("Ada is a programming language designed "), + 2 => Equiv("to support long-lived, reliable software"), + 3 => Equiv(" systems. "), + 4 => Equiv("Go with Ada! ")); + + ----- + + + procedure Enter_Text_Into_Document (Document : in out Document_Type) is + begin + + -- Fill in both "paragraphs" of the document. Each unbounded wide + -- string functions as an individual paragraph, containing an + -- unspecified number of characters. + -- Use a variety of different unbounded wide string subprograms to + -- load the data. + + Document(1) := + ASW.To_Unbounded_Wide_String(Equiv("Ada is a language")); + + -- Insert the word "programming" prior to "language". + Document(1) := + ASW.Insert(Document(1), + ASW.Index(Document(1), + Equiv("language")), + ASW.To_Wide_String(Equiv("progra") & -- Wd Str & + ASW."*"(2,Equiv('m')) & -- Wd Unbd & + Equiv("ing "))); -- Wd Str + + + -- Overwrite the word "language" with "language" + additional text. + Document(1) := + ASW.Overwrite(Document(1), + ASW.Index(Document(1), + ASW.To_Wide_String( + ASW.Tail(Document(1), 8, Equiv(' '))), + Ada.Strings.Backward), + Equiv("language designed to support long-lifed")); + + + -- Replace the word "lifed" with "lived". + Document(1) := + ASW.Replace_Slice(Document(1), + ASW.Index(Document(1), Equiv("lifed")), + ASW.Length(Document(1)), + Equiv("lived")); + + + -- Overwrite the word "lived" with "lived" + additional text. + Document(1) := + ASW.Overwrite(Document(1), + ASW.Index(Document(1), + ASW.To_Wide_String + (ASW.Tail(Document(1), 5, Equiv(' '))), + Ada.Strings.Backward), + Equiv("lived, reliable software systems.")); + + + -- Use several of the overloaded versions of "&" to form this + -- unbounded wide string. + + Document(2) := Equiv('G') & + ASW.To_Unbounded_Wide_String(Equiv("o ")) & + ASW.To_Unbounded_Wide_String(Equiv("with")) & + Equiv(' ') & + Equiv("Ada!"); + + end Enter_Text_Into_Document; + + + ----- + + + procedure Create_Camera_Ready_Copy + (Document : in Document_Type; + Camera_Copy : out Camera_Ready_Copy_Type) is + begin + -- Break the unbounded wide strings into fixed lengths. + + -- Search the first unbounded wide string for portions of text that + -- are less than or equal to the length of a wide string in the + -- Camera_Ready_Copy_Type object. + + Camera_Copy(1) := -- Take characters 1-39, + ASW.Slice(Document(1), -- and append a blank space. + 1, + ASW.Index(ASW.To_Unbounded_Wide_String + (ASW.Slice(Document(1), + 1, + Line_Length)), + Ada.Strings.Wide_Maps.To_Set(Equiv(' ')), + Ada.Strings.Inside, + Ada.Strings.Backward)) & Equiv(' '); + + Camera_Copy(2) := -- Take characters 40-79. + ASW.Slice(Document(1), + 40, + (ASW.Index_Non_Blank -- Should return 79 + (ASW.To_Unbounded_Wide_String + (ASW.Slice(Document(1), -- Slice (40..79) + 40, + 79)), + Ada.Strings.Backward) + 39)); -- Increment since + -- this slice starts + -- at 40. + + Camera_Copy(3)(1..9) := ASW.Slice(Document(1), -- Characters 80-88 + 80, + ASW.Length(Document(1))); + + + -- Break the second unbounded wide string into the appropriate + -- length. It is only twelve characters in length, so the entire + -- unbounded wide string will be placed on one string of the output + -- object. + + Camera_Copy(4)(1..ASW.Length(Document(2))) := + ASW.To_Wide_String(ASW.Head(Document(2), + ASW.Length(Document(2)))); + + end Create_Camera_Ready_Copy; + + + ----- + + + function Valid_Proofread (Draft, Master : Camera_Ready_Copy_Type) + return Boolean is + begin + + -- Evaluate wide strings for equality, using the operators defined + -- in package Ada.Strings.Wide_Unbounded. The less than/greater + -- than or equal comparisons should evaluate to "equals => True". + + if ASW.To_Unbounded_Wide_String(Draft(1)) = -- "="(WUnb,WUnb) + ASW.To_Unbounded_Wide_String(Master(1)) and + ASW.To_Unbounded_Wide_String(Draft(2)) <= -- "<="(WUnb,WUnb) + ASW.To_Unbounded_Wide_String(Master(2)) and + ASW.To_Unbounded_Wide_String(Draft(3)) >= -- ">="(WUnb,WUnb) + ASW.To_Unbounded_Wide_String(Master(3)) and + ASW.To_Unbounded_Wide_String(Draft(4)) = -- "="(WUnb,WUnb) + ASW.To_Unbounded_Wide_String(Master(4)) + then + return True; + else + return False; + end if; + + end Valid_Proofread; + + + ----- + + + begin + + -- Enter text into the unbounded wide string paragraphs of the document. + + Enter_Text_Into_Document (Pamphlet); + + + -- Reformat the unbounded wide strings into fixed wide string format. + + Create_Camera_Ready_Copy (Document => Pamphlet, + Camera_Copy => Camera_Ready_Copy); + + + -- Verify the conversion process. + + if not Valid_Proofread (Draft => Camera_Ready_Copy, + Master => TC_Finished_Product) + then + Report.Failed ("Incorrect unbounded wide string processing result"); + end if; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + + Report.Result; + +end CXA4021; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4022.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4022.a new file mode 100644 index 000000000..3c649a1a2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4022.a @@ -0,0 +1,531 @@ +-- CXA4022.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 subprograms defined in package +-- Ada.Strings.Wide_Unbounded are available, and that they produce +-- correct results. Specifically, check the subprograms Count, Element, +-- Index, Replace_Element, To_Unbounded_Wide_String, and "&", ">", "<". +-- +-- TEST DESCRIPTION: +-- This test demonstrates the uses of many of the subprograms defined +-- in package Ada.Strings.Wide_Unbounded for use with unbounded wide +-- strings. The test simulates how unbounded wide strings +-- will be processed in a user environment, using the subprograms +-- provided in this package. +-- +-- Taken in conjunction with tests CXA4021 and CXA4023, this test will +-- constitute a test of the functionality contained in package +-- Ada.Strings.Wide Unbounded. This test uses a variety +-- of the subprograms defined in the unbounded wide string package +-- in ways typical of common usage, with different combinations of +-- available subprograms being used to accomplish similar +-- unbounded wide string processing goals. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 08 Nov 95 SAIC Corrected accessibility level, type visibility, +-- and subtest acceptance criteria problems for +-- ACVC 2.0.1 +-- +--! + +with Ada.Characters.Handling; +with Ada.Strings; + +package CXA40220 is + + -- The following two functions are used to translate character and string + -- values to "Wide" values. They will be applied to all the Wide_Bounded + -- subprogram character and string parameters to simulate the use of non- + -- character Wide_Characters and Wide_Strings in actual practice. + -- Note: These functions do not actually return "equivalent" wide + -- characters to their character inputs, just "non-character" + -- wide characters. + + function Equiv (Ch : Character) return Wide_Character; + + function Equiv (Str : String) return Wide_String; + + + -- Functions and access-to-subprogram value used to supply mapping + -- capability to the appropriate versions of Count, Index, and + -- Translate. + + function AB_to_US_Mapping_Function (From : Wide_Character) + return Wide_Character; + + function AB_to_Blank_Mapping_Function (From : Wide_Character) + return Wide_Character; + +end CXA40220; + +package body CXA40220 is + + function Equiv (Ch : Character) return Wide_Character is + C : Character := Ch; + begin + if Ch = ' ' then + return Ada.Characters.Handling.To_Wide_Character(C); + else + return Wide_Character'Val(Character'Pos(Ch) + + Character'Pos(Character'Last) + 1); + end if; + end Equiv; + + + function Equiv (Str : String) return Wide_String is + WS : Wide_String(Str'First..Str'Last); + begin + for i in Str'First..Str'Last loop + WS(i) := Equiv(Str(i)); + end loop; + return WS; + end Equiv; + + + function AB_to_US_Mapping_Function (From : Wide_Character) + return Wide_Character is + UnderScore : constant Wide_Character := Equiv('_'); + begin + if From = Equiv('a') or From = Equiv('b') then + return UnderScore; + else + return From; + end if; + end AB_to_US_Mapping_Function; + + + function AB_to_Blank_Mapping_Function (From : Wide_Character) + return Wide_Character is + begin + if From = Equiv('a') or From = Equiv('b') then + return Ada.Strings.Wide_Space; + else + return From; + end if; + end AB_to_Blank_Mapping_Function; + +end CXA40220; + + +with CXA40220; +with Report; +with Ada.Characters.Handling; +with Ada.Strings.Wide_Maps; +with Ada.Strings.Wide_Unbounded; + +procedure CXA4022 is +begin + + Report.Test ("CXA4022", "Check that the subprograms defined in " & + "package Ada.Strings.Wide_Unbounded are " & + "available, and that they produce correct " & + "results"); + + Test_Block: + declare + + use CXA40220; + + package ASW renames Ada.Strings.Wide_Unbounded; + use Ada.Strings; + use type Wide_Maps.Wide_Character_Set; + use type ASW.Unbounded_Wide_String; + + Test_String : ASW.Unbounded_Wide_String; + AtoE_Str : ASW.Unbounded_Wide_String := + ASW.To_Unbounded_Wide_String(Equiv("abcde")); + + Complete_String : ASW.Unbounded_Wide_String := + ASW."&"(ASW.To_Unbounded_Wide_String(Equiv("Incomplete")), + ASW."&"(Ada.Strings.Wide_Space, + ASW.To_Unbounded_Wide_String(Equiv("String")))); + + Incomplete_String : ASW.Unbounded_Wide_String := + ASW.To_Unbounded_Wide_String + (Equiv("ncomplete Strin")); + + Incorrect_Spelling : ASW.Unbounded_Wide_String := + ASW.To_Unbounded_Wide_String(Equiv("Guob Dai")); + + Magic_String : ASW.Unbounded_Wide_String := + ASW.To_Unbounded_Wide_String(Equiv("abracadabra")); + + Incantation : ASW.Unbounded_Wide_String := Magic_String; + + + A_Small_G : Wide_Character := Equiv('g'); + A_Small_D : Wide_Character := Equiv('d'); + + ABCD_Set : Wide_Maps.Wide_Character_Set := + Wide_Maps.To_Set(Equiv("abcd")); + B_Set : Wide_Maps.Wide_Character_Set := + Wide_Maps.To_Set(Equiv('b')); + CD_Set : Wide_Maps.Wide_Character_Set := + Wide_Maps.To_Set(Equiv("cd")); + + CD_to_XY_Map : Wide_Maps.Wide_Character_Mapping := + Wide_Maps.To_Mapping(From => Equiv("cd"), + To => Equiv("xy")); + AB_to_YZ_Map : Wide_Maps.Wide_Character_Mapping := + Wide_Maps.To_Mapping(Equiv("ab"), Equiv("yz")); + + + Matching_Letters : Natural := 0; + Location, + Total_Count : Natural := 0; + + + Map_Ptr : Wide_Maps.Wide_Character_Mapping_Function := + AB_to_US_Mapping_Function'Access; + + + begin + + + -- Function "&" + + -- Prepend an 'I' and append a 'g' to the wide string. + Incomplete_String := ASW."&"(Equiv('I'), + Incomplete_String); -- Ch & W Unb + Incomplete_String := ASW."&"(Incomplete_String, + A_Small_G); -- W Unb & Ch + + if ASW."<"(Incomplete_String, Complete_String) or + ASW.">"(Incomplete_String, Complete_String) or + Incomplete_String /= Complete_String + then + Report.Failed("Incorrect result from use of ""&"" operator"); + end if; + + + + -- Function Element + + -- Last element of the unbounded wide string should be a 'g'. + if ASW.Element(Incomplete_String, ASW.Length(Incomplete_String)) /= + A_Small_G + then + Report.Failed("Incorrect result from use of Function Element - 1"); + end if; + + if ASW.Element(Incomplete_String, 2) /= + ASW.Element(ASW.Tail(Incomplete_String, 2), 1) or + ASW.Element(ASW.Head(Incomplete_String, 4), 2) /= + ASW.Element(ASW.To_Unbounded_Wide_String(Equiv("wnqz")), 2) + then + Report.Failed("Incorrect result from use of Function Element - 2"); + end if; + + + + -- Procedure Replace_Element + + -- The unbounded wide string Incorrect_Spelling starts as "Guob Dai", + -- and is transformed by the following three procedure calls to + -- "Good Day". + + ASW.Replace_Element(Incorrect_Spelling, 2, Equiv('o')); + + ASW.Replace_Element(Incorrect_Spelling, + ASW.Index(Incorrect_Spelling, B_Set), + A_Small_D); + + ASW.Replace_Element(Source => Incorrect_Spelling, + Index => ASW.Length(Incorrect_Spelling), + By => Equiv('y')); + + if Incorrect_Spelling /= + ASW.To_Unbounded_Wide_String(Equiv("Good Day")) + then + Report.Failed("Incorrect result from Procedure Replace_Element"); + end if; + + + + -- Function Index with non-Identity map. + -- Evaluate the function Index with a non-identity map + -- parameter which will cause mapping of the source parameter + -- prior to the evaluation of the index position search. + + Location := ASW.Index(Source => ASW.To_Unbounded_Wide_String + (Equiv("abcdefghij")), + Pattern => Equiv("xy"), + Going => Ada.Strings.Forward, + Mapping => CD_to_XY_Map); -- change "cd" to "xy" + + if Location /= 3 then + Report.Failed("Incorrect result from Index, non-Identity map - 1"); + end if; + + Location := ASW.Index(ASW.To_Unbounded_Wide_String(Equiv("abcdabcdab")), + Equiv("yz"), + Ada.Strings.Backward, + AB_to_YZ_Map); -- change all "ab" to "yz" + + if Location /= 9 then + Report.Failed("Incorrect result from Index, non-Identity map - 2"); + end if; + + -- A couple with identity maps (default) as well. + + if ASW.Index(ASW.To_Unbounded_Wide_String(Equiv("abcd")), -- Pat = Src + Equiv("abcd")) /= 1 or + ASW.Index(ASW.To_Unbounded_Wide_String(Equiv("abc")), -- Pat < Src + Equiv("abcd")) /= 0 or + ASW.Index(ASW.Null_Unbounded_Wide_String, -- Src = Null + Equiv("abc")) /= 0 + then + Report.Failed + ("Incorrect result from Index with wide string patterns"); + end if; + + + + -- Function Index (for Sets). + -- This version of Index uses Sets as the basis of the search. + + -- Test = Inside, Going = Forward (Default case). + Location := + ASW.Index(Source => ASW.To_Unbounded_Wide_String(Equiv("abcdeabcde")), + Set => CD_Set); -- set containing 'c' and 'd' + + if not (Location = 3) then -- position of first 'c' in source. + Report.Failed("Incorrect result from Index using Sets - 1"); + end if; + + -- Test = Inside, Going = Backward. + Location := + ASW.Index(Source => ASW."&"(AtoE_Str, AtoE_Str), + Set => CD_Set, -- set containing 'c' and 'd' + Test => Ada.Strings.Inside, + Going => Ada.Strings.Backward); + + if not (Location = 9) then -- position of last 'd' in source. + Report.Failed("Incorrect result from Index using Sets - 2"); + end if; + + -- Test = Outside, Going = Forward, Backward + if ASW.Index(ASW.To_Unbounded_Wide_String(Equiv("deddacd")), + Wide_Maps.To_Set(Equiv("xydcgf")), + Test => Ada.Strings.Outside, + Going => Ada.Strings.Forward) /= 2 or + ASW.Index(ASW.To_Unbounded_Wide_String(Equiv("deddacd")), + Wide_Maps.To_Set(Equiv("xydcgf")), + Test => Ada.Strings.Outside, + Going => Ada.Strings.Backward) /= 5 or + ASW.Index(ASW.To_Unbounded_Wide_String(Equiv("deddacd")), + CD_Set, + Ada.Strings.Outside, + Ada.Strings.Backward) /= 5 + then + Report.Failed("Incorrect result from Index using Sets - 3"); + end if; + + -- Default direction (forward) and mapping (identity). + + if ASW.Index(ASW.To_Unbounded_Wide_String(Equiv("cd")), -- Source = Set + CD_Set) /= 1 or + ASW.Index(ASW.To_Unbounded_Wide_String(Equiv("c")), -- Source < Set + CD_Set) /= 1 or + ASW.Index(ASW.Null_Unbounded_Wide_String, -- Source = Null + CD_Set) /= 0 or + ASW.Index(AtoE_Str, + Wide_Maps.Null_Set) /= 0 or -- Null set + ASW.Index(AtoE_Str, + Wide_Maps.To_Set(Equiv('x'))) /= 0 -- No match. + then + Report.Failed("Incorrect result from Index using Sets - 4"); + end if; + + + + -- Function Index using access-to-subprogram mapping. + -- Evaluate the function Index with an access value that supplies the + -- mapping function for this version of Index. + + Map_Ptr := AB_to_US_Mapping_Function'Access; + + Location := ASW.Index(Source => ASW.To_Unbounded_Wide_String + (Equiv("xAxabbxax xaax _cx")), + Pattern => Equiv("_x"), + Going => Ada.Strings.Forward, + Mapping => Map_Ptr); -- change 'a'or 'b' to '_' + + if Location /= 6 then -- location of "bx" substring + Report.Failed("Incorrect result from Index, access value map - 1"); + end if; + + Map_Ptr := AB_to_Blank_Mapping_Function'Access; + + Location := ASW.Index(ASW.To_Unbounded_Wide_String + (Equiv("ccacdcbbcdacc")), + Equiv("cd "), + Ada.Strings.Backward, + Map_Ptr); -- change 'a' or 'b' to ' ' + + if Location /= 9 then + Report.Failed("Incorrect result from Index, access value map - 2"); + end if; + + if ASW.Index(ASW.To_Unbounded_Wide_String(Equiv("abcd")), + Equiv(" cd"), + Ada.Strings.Forward, + Map_Ptr) /= 1 or + ASW.Index(ASW.To_Unbounded_Wide_String(Equiv("abc")), + Equiv(" c "), -- No match + Ada.Strings.Backward, + Map_Ptr) /= 0 + then + Report.Failed("Incorrect result from Index, access value map - 3"); + end if; + + + + -- Function Count + + -- Determine the number of characters in the unbounded wide string that + -- are contained in the set. + + Matching_Letters := ASW.Count(Source => Magic_String, + Set => ABCD_Set); + + if Matching_Letters /= 9 then + Report.Failed + ("Incorrect result from Function Count with Set parameter"); + end if; + + -- Determine the number of occurrences of the following pattern wide + -- strings in the unbounded wide string Magic_String. + + if ASW.Count(Magic_String, Equiv("ab")) /= + (ASW.Count(Magic_String, Equiv("ac")) + + ASW.Count(Magic_String, Equiv("ad"))) or + ASW.Count(Magic_String, Equiv("ab")) /= 2 + then + Report.Failed + ("Incorrect result from Function Count, wide string parameter"); + end if; + + + + -- Function Count with non-Identity mapping. + -- Evaluate the function Count with a non-identity map + -- parameter which will cause mapping of the source parameter + -- prior to the evaluation of the number of matching patterns. + + Total_Count := + ASW.Count(ASW.To_Unbounded_Wide_String(Equiv("abbabbabbabba")), + Pattern => Equiv("yz"), + Mapping => AB_to_YZ_Map); + + if Total_Count /= 4 then + Report.Failed + ("Incorrect result from function Count, non-Identity map - 1"); + end if; + + if ASW.Count(ASW.To_Unbounded_Wide_String(Equiv("ADCBADABCD")), + Equiv("AB"), + Wide_Maps.To_Mapping(Equiv("CD"), Equiv("AB"))) /= 5 or + ASW.Count(ASW.To_Unbounded_Wide_String(Equiv("dcccddcdccdddccccd")), + Equiv("xxy"), + CD_to_XY_Map) /= 3 + then + Report.Failed + ("Incorrect result from function Count, non-Identity map - 2"); + end if; + + -- And a few with identity Wide_Maps as well. + + if ASW.Count(ASW.To_Unbounded_Wide_String(Equiv("ABABABABAB")), + Equiv("ABA"), + Wide_Maps.Identity) /= 2 or + ASW.Count(ASW.To_Unbounded_Wide_String(Equiv("aaaaaaaaaa")), + Equiv("aaa")) /= 3 or + ASW.Count(ASW.To_Unbounded_Wide_String(Equiv("XX")), -- Src < Pat + Equiv("XXX"), + Wide_Maps.Identity) /= 0 or + ASW.Count(AtoE_Str, -- Source = Pattern + Equiv("abcde")) /= 1 or + ASW.Count(ASW.Null_Unbounded_Wide_String, -- Source = Null + Equiv(" ")) /= 0 + then + Report.Failed + ("Incorrect result from function Count, w,w/o mapping"); + end if; + + + + -- Function Count using access-to-subprogram mapping. + -- Evaluate the function Count with an access value specifying the + -- mapping that is going to occur to Source. + + Map_Ptr := AB_to_US_Mapping_Function'Access; + + Total_Count := + ASW.Count(ASW.To_Unbounded_Wide_String(Equiv("abcbacbadbaAbbB")), + Pattern => Equiv("__"), + Mapping => Map_Ptr); -- change 'a' and 'b' to '_' + + if Total_Count /= 5 then + Report.Failed + ("Incorrect result from function Count, access value map - 1"); + end if; + + Map_Ptr := AB_to_Blank_Mapping_Function'Access; + + if ASW.Count(ASW.To_Unbounded_Wide_String(Equiv("cccaccBcbcaccacAc")), + Equiv("c c"), + Map_Ptr) /= 3 or + ASW.Count(ASW.To_Unbounded_Wide_String + (Equiv("aBBAAABaBBBBAaBABBABaBBbBB")), + Equiv(" BB"), + Map_Ptr) /= 4 or + ASW.Count(ASW.To_Unbounded_Wide_String(Equiv("aaaaaaaaaa")), + Equiv(" "), + Map_Ptr) /= 3 or + ASW.Count(ASW.To_Unbounded_Wide_String(Equiv("XX")), -- Src < Pat + Equiv("XX "), + Map_Ptr) /= 0 or + ASW.Count(AtoE_Str, -- Source'Length = Pattern'Length + Equiv(" cde"), + Map_Ptr) /= 1 + then + Report.Failed + ("Incorrect result from function Count, access value map - 3"); + end if; + + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + + Report.Result; + +end CXA4022; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4023.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4023.a new file mode 100644 index 000000000..d0325fc88 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4023.a @@ -0,0 +1,585 @@ +-- CXA4023.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 subprograms defined in package +-- Ada.Strings.Wide_Unbounded are available, and that they produce +-- correct results. Specifically, check the subprograms Delete, +-- Find_Token, Translate, Trim, and "*". +-- +-- TEST DESCRIPTION: +-- This test demonstrates the uses of many of the subprograms defined +-- in package Ada.Strings.Wide_Unbounded for use with unbounded wide +-- strings. The test simulates how unbounded wide strings +-- will be processed in a user environment, using the subprograms +-- provided in this package. +-- +-- This test, when taken in conjunction with tests CXA4021-22, will +-- constitute a test of the functionality contained in package +-- Ada.Strings.Wide_Unbounded. This test uses a variety +-- of the subprograms defined in the unbounded wide string package +-- in ways typical of common usage, with different combinations of +-- available subprograms being used to accomplish similar +-- unbounded wide string processing goals. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 08 Nov 95 SAIC Corrected accessibility level and type +-- visibility problems for ACVC 2.0.1. +-- +--! + +with Ada.Characters.Handling; +with Ada.Strings; + +package CXA40230 is + + -- The following two functions are used to translate character and string + -- values to non-character "Wide" values. They will be applied to all the + -- Wide_Bounded subprogram character and string parameters to simulate the + -- use of Wide_Characters and Wide_Strings in actual practice. + -- Note: These functions do not actually return "equivalent" wide + -- characters to their character inputs, just "non-character" + -- wide characters. + + function Equiv (Ch : Character) return Wide_Character; + + function Equiv (Str : String) return Wide_String; + + -- Functions and access-to-subprogram object used to supply mapping + -- capability to the appropriate versions of Translate. + + function AB_to_US_Mapping_Function (From : Wide_Character) + return Wide_Character; + + function AB_to_Blank_Mapping_Function (From : Wide_Character) + return Wide_Character; + +end CXA40230; + + +package body CXA40230 is + + function Equiv (Ch : Character) return Wide_Character is + C : Character := Ch; + begin + if Ch = ' ' then + return Ada.Characters.Handling.To_Wide_Character(C); + else + return Wide_Character'Val(Character'Pos(Ch) + + Character'Pos(Character'Last) + 1); + end if; + end Equiv; + + + function Equiv (Str : String) return Wide_String is + WS : Wide_String(Str'First..Str'Last); + begin + for i in Str'First..Str'Last loop + WS(i) := Equiv(Str(i)); + end loop; + return WS; + end Equiv; + + + function AB_to_US_Mapping_Function (From : Wide_Character) + return Wide_Character is + UnderScore : constant Wide_Character := Equiv('_'); + begin + if From = Equiv('a') or From = Equiv('b') then + return UnderScore; + else + return From; + end if; + end AB_to_US_Mapping_Function; + + + function AB_to_Blank_Mapping_Function (From : Wide_Character) + return Wide_Character is + begin + if From = Equiv('a') or From = Equiv('b') then + return Ada.Strings.Wide_Space; + else + return From; + end if; + end AB_to_Blank_Mapping_Function; + +end CXA40230; + + +with CXA40230; +with Report; +with Ada.Characters.Handling; +with Ada.Strings.Wide_Maps; +with Ada.Strings.Wide_Unbounded; + +procedure CXA4023 is +begin + + Report.Test ("CXA4023", "Check that the subprograms defined in " & + "package Ada.Strings.Wide_Unbounded are " & + "available, and that they produce correct " & + "results"); + + Test_Block: + declare + + use CXA40230; + + package ASW renames Ada.Strings.Wide_Unbounded; + use Ada.Strings; + use type Wide_Maps.Wide_Character_Set; + use type ASW.Unbounded_Wide_String; + + Test_String : ASW.Unbounded_Wide_String; + AtoE_Str : ASW.Unbounded_Wide_String := + ASW.To_Unbounded_Wide_String(Equiv("abcde")); + + Cad_String : ASW.Unbounded_Wide_String := + ASW.To_Unbounded_Wide_String(Equiv("cad")); + + Magic_String : ASW.Unbounded_Wide_String := + ASW.To_Unbounded_Wide_String(Equiv("abracadabra")); + + Incantation : ASW.Unbounded_Wide_String := Magic_String; + + + A_Small_G : Wide_Character := Equiv('g'); + + ABCD_Set : Wide_Maps.Wide_Character_Set := + Wide_Maps.To_Set(Equiv("abcd")); + B_Set : Wide_Maps.Wide_Character_Set := + Wide_Maps.To_Set(Equiv('b')); + AB_Set : Wide_Maps.Wide_Character_Set := + Wide_Maps."OR"(Wide_Maps.To_Set(Equiv('a')), B_Set); + + + AB_to_YZ_Map : Wide_Maps.Wide_Character_Mapping := + Wide_Maps.To_Mapping(From => Equiv("ab"), + To => Equiv("yz")); + Code_Map : Wide_Maps.Wide_Character_Mapping := + Wide_Maps.To_Mapping(Equiv("abcd"), Equiv("wxyz")); + Reverse_Code_Map : Wide_Maps.Wide_Character_Mapping := + Wide_Maps.To_Mapping(Equiv("wxyz"), Equiv("abcd")); + Non_Existent_Map : Wide_Maps.Wide_Character_Mapping := + Wide_Maps.To_Mapping(Equiv("jkl"), Equiv("mno")); + + + Token_Start : Positive; + Token_End : Natural := 0; + + Map_Ptr : Wide_Maps.Wide_Character_Mapping_Function := + AB_to_US_Mapping_Function'Access; + + + begin + + -- Find_Token + + ASW.Find_Token(Magic_String, -- Find location of first "ab" equiv. + AB_Set, -- Should be (1..2). + Ada.Strings.Inside, + Token_Start, + Token_End); + + if Natural(Token_Start) /= ASW.To_Wide_String(Magic_String)'First or + Token_End /= ASW.Index(Magic_String, B_Set) or + Token_End /= 2 + then + Report.Failed("Incorrect result from Procedure Find_Token - 1"); + end if; + + + ASW.Find_Token(Source => Magic_String, -- Find location of char 'r'equiv + Set => ABCD_Set, -- in wide str, should be (3..3) + Test => Ada.Strings.Outside, + First => Token_Start, + Last => Token_End); + + if Natural(Token_Start) /= 3 or Token_End /= 3 then + Report.Failed("Incorrect result from Procedure Find_Token - 2"); + end if; + + + ASW.Find_Token(Magic_String, -- No 'g' "equivalent in + Wide_Maps.To_Set(A_Small_G), -- the wide str, so the + Ada.Strings.Inside, -- result params should be + First => Token_Start, -- First = Source'First and + Last => Token_End); -- Last = 0. + + + if Token_Start /= ASW.To_Wide_String(Magic_String)'First or + Token_End /= 0 + then + Report.Failed("Incorrect result from Procedure Find_Token - 3"); + end if; + + + ASW.Find_Token(ASW.To_Unbounded_Wide_String(Equiv("abpqpqrttrcpqr")), + Wide_Maps.To_Set(Equiv("trpq")), + Ada.Strings.Inside, + Token_Start, + Token_End); + + if Token_Start /= 3 or + Token_End /= 10 + then + Report.Failed("Incorrect result from Procedure Find_Token - 4"); + end if; + + ASW.Find_Token(ASW.To_Unbounded_Wide_String(Equiv("abpqpqrttrcpqr")), + Wide_Maps.To_Set(Equiv("abpq")), + Ada.Strings.Outside, + Token_Start, + Token_End); + + if Token_Start /= 7 or + Token_End /= 11 + then + Report.Failed("Incorrect result from Procedure Find_Token - 5"); + end if; + + + + -- Translate + + -- Use a mapping ("abcd" -> "wxyz") to transform the contents of + -- the unbounded wide string. + -- Magic_String = "abracadabra" + + Incantation := ASW.Translate(Magic_String, Code_Map); + + if Incantation /= + ASW.To_Unbounded_Wide_String(Equiv("wxrwywzwxrw")) + then + Report.Failed("Incorrect result from Function Translate - 1"); + end if; + + -- (Note: See below for additional testing of Function Translate) + + -- Use the inverse mapping of the one above to return the "translated" + -- unbounded wide string to its original form. + + ASW.Translate(Incantation, Reverse_Code_Map); + + -- The map contained in the following call to Translate contains three + -- elements, and these elements are not found in the unbounded wide + -- string, so this call to Translate should have no effect on it. + + if Incantation /= ASW.Translate(Magic_String, Non_Existent_Map) then + Report.Failed("Incorrect result from Procedure Translate - 1"); + end if; + + -- Partial mapping of source. + + Test_String := ASW.To_Unbounded_Wide_String(Equiv("abcdeabcab")); + + ASW.Translate(Source => Test_String, Mapping => AB_to_YZ_Map); + + if Test_String /= ASW.To_Unbounded_Wide_String(Equiv("yzcdeyzcyz")) then + Report.Failed("Incorrect result from Procedure Translate - 2"); + end if; + + -- Total mapping of source. + + Test_String := ASW.To_Unbounded_Wide_String(Equiv("abbaaababb")); + + ASW.Translate(Source => Test_String, Mapping => AB_to_YZ_Map); + + if Test_String /= ASW.To_Unbounded_Wide_String(Equiv("yzzyyyzyzz")) then + Report.Failed("Incorrect result from Procedure Translate - 3"); + end if; + + -- No mapping of source. + + Test_String := ASW.To_Unbounded_Wide_String(Equiv("xyzsypcc")); + + ASW.Translate(Source => Test_String, Mapping => AB_to_YZ_Map); + + if Test_String /= ASW.To_Unbounded_Wide_String(Equiv("xyzsypcc")) then + Report.Failed("Incorrect result from Procedure Translate - 4"); + end if; + + -- Map > 2 characters, partial mapping. + + Test_String := ASW.To_Unbounded_Wide_String(Equiv("opabcdelmn")); + + ASW.Translate(Test_String, + Wide_Maps.To_Mapping(Equiv("abcde"), Equiv("lmnop"))); + + if Test_String /= ASW.To_Unbounded_Wide_String(Equiv("oplmnoplmn")) then + Report.Failed("Incorrect result from Procedure Translate - 5"); + end if; + + + + -- Various degrees of mapping of source (full, partial, none) used + -- with Function Translate. + + if ASW.Translate( + ASW.To_Unbounded_Wide_String(Equiv("abcdeabcabbbaaacaa")), + AB_to_YZ_Map) /= + ASW.To_Unbounded_Wide_String(Equiv("yzcdeyzcyzzzyyycyy")) or + + ASW.Translate( + ASW.To_Unbounded_Wide_String(Equiv("abbaaababbaaaaba")), + AB_to_YZ_Map) /= + ASW.To_Unbounded_Wide_String(Equiv("yzzyyyzyzzyyyyzy")) or + + ASW.Translate(ASW.To_Unbounded_Wide_String(Equiv("cABcABBAc")), + Mapping => AB_to_YZ_Map) /= + ASW.To_Unbounded_Wide_String(Equiv("cABcABBAc")) or + + ASW.Translate(ASW.To_Unbounded_Wide_String("opabcdelmnddeaccabec"), + Wide_Maps.To_Mapping("abcde", "lmnop")) /= + ASW.To_Unbounded_Wide_String("oplmnoplmnooplnnlmpn") + then + Report.Failed("Incorrect result from Function Translate - 2"); + end if; + + + + -- Procedure Translate using access-to-subprogram mapping. + -- Partial mapping of source. + + Map_Ptr := AB_to_Blank_Mapping_Function'Access; + + Test_String := ASW.To_Unbounded_Wide_String(Equiv("abABaABbaBAbba")); + + ASW.Translate(Source => Test_String, -- change equivalent of 'a' and + Mapping => Map_Ptr); -- 'b' to ' ' + + if Test_String /= + ASW.To_Unbounded_Wide_String(Equiv(" AB AB BA ")) + then + Report.Failed + ("Incorrect result from Proc Translate, w/ access value map - 1"); + end if; + + -- Total mapping of source to blanks. + + Test_String := ASW.To_Unbounded_Wide_String(Equiv("abbbab")); + + ASW.Translate(Source => Test_String, + Mapping => Map_Ptr); + + if Test_String /= + ASW.To_Unbounded_Wide_String(Equiv(" ")) + then + Report.Failed + ("Incorrect result from Proc Translate, w/ access value map - 2"); + end if; + + -- No mapping of source. + + Map_Ptr := AB_to_US_Mapping_Function'Access; + + Test_String := ASW.To_Unbounded_Wide_String(Equiv("xyzsypcc")); + + ASW.Translate(Source => Test_String, + Mapping => Map_Ptr); + + if Test_String /= + ASW.To_Unbounded_Wide_String(Equiv("xyzsypcc")) -- no change + then + Report.Failed + ("Incorrect result from Proc Translate, w/ access value map - 3"); + end if; + + + -- Function Translate using access-to-subprogram mapping value. + + Map_Ptr := AB_to_Blank_Mapping_Function'Access; + + Test_String := ASW.To_Unbounded_Wide_String(Equiv("abAbBBAabbacD")); + + if ASW.Translate(ASW.Translate(Test_String, Map_Ptr), Map_Ptr) /= + ASW.To_Unbounded_Wide_String(Equiv(" A BBA cD")) + then + Report.Failed + ("Incorrect result from Function Translate, access value map - 1"); + end if; + + if ASW.Translate(Source => ASW.To_Unbounded_Wide_String(Equiv("a")), + Mapping => Map_Ptr) /= + ASW.To_Unbounded_Wide_String(Equiv(" ")) or + ASW.Translate(ASW.To_Unbounded_Wide_String + (Equiv(" aa Aa A AAaaa a aA")), + Map_Ptr) /= + ASW.To_Unbounded_Wide_String(Equiv(" A A AA A")) or + ASW.Translate(Source => ASW.To_Unbounded_Wide_String(Equiv("a ")), + Mapping => Map_Ptr) /= + ASW.To_Unbounded_Wide_String(Equiv(" ")) or + ASW.Translate(Source => ASW.To_Unbounded_Wide_String(Equiv("xyz")), + Mapping => Map_Ptr) /= + ASW.To_Unbounded_Wide_String(Equiv("xyz")) + then + Report.Failed + ("Incorrect result from Function Translate, access value map - 2"); + end if; + + + + -- Trim + + Trim_Block: + declare + + XYZ_Set : Wide_Maps.Wide_Character_Set := + Wide_Maps.To_Set(Equiv("xyz")); + PQR_Set : Wide_Maps.Wide_Character_Set := + Wide_Maps.To_Set(Equiv("pqr")); + + Pad : constant ASW.Unbounded_Wide_String := + ASW.To_Unbounded_Wide_String(Equiv("Pad")); + + The_New_Ada : constant ASW.Unbounded_Wide_String := + ASW.To_Unbounded_Wide_String(Equiv("Ada9X")); + + Space_Array : array (1..4) of ASW.Unbounded_Wide_String := + (ASW.To_Unbounded_Wide_String(Equiv(" Pad ")), + ASW.To_Unbounded_Wide_String(Equiv("Pad ")), + ASW.To_Unbounded_Wide_String(Equiv(" Pad")), + Pad); + + String_Array : array (1..5) of ASW.Unbounded_Wide_String := + (ASW.To_Unbounded_Wide_String(Equiv("xyzxAda9Xpqr")), + ASW.To_Unbounded_Wide_String(Equiv("Ada9Xqqrp")), + ASW.To_Unbounded_Wide_String(Equiv("zxyxAda9Xqpqr")), + ASW.To_Unbounded_Wide_String(Equiv("xxxyAda9X")), + The_New_Ada); + + begin + + -- Examine the version of Trim that removes blanks from + -- the left and/or right of a wide string. + + for i in 1..4 loop + if ASW.Trim(Space_Array(i), Ada.Strings.Both) /= Pad then + Report.Failed("Incorrect result from Trim for spaces - " & + Integer'Image(i)); + end if; + end loop; + + -- Examine the version of Trim that removes set characters from + -- the left and right of a wide string. + + for i in 1..5 loop + if ASW.Trim(String_Array(i), + Left => XYZ_Set, + Right => PQR_Set) /= The_New_Ada then + Report.Failed + ("Incorrect result from Trim for set characters - " & + Integer'Image(i)); + end if; + end loop; + + -- No trimming. + + if ASW.Trim( + ASW.To_Unbounded_Wide_String(Equiv("prqqprAda9Xyzzxyzzyz")), + XYZ_Set, + PQR_Set) /= + ASW.To_Unbounded_Wide_String(Equiv("prqqprAda9Xyzzxyzzyz")) + then + Report.Failed + ("Incorrect result from Trim for set, no trimming"); + end if; + + end Trim_Block; + + + + -- Delete + + -- Use the Delete function to remove the first four and last four + -- characters from the wide string. + + if ASW.Delete(Source => ASW.Delete(Magic_String, + 8, + ASW.Length(Magic_String)), + From => ASW.To_Wide_String(Magic_String)'First, + Through => 4) /= + Cad_String + then + Report.Failed("Incorrect results from Function Delete"); + end if; + + + + -- Constructors ("*") + + Constructor_Block: + declare + + SOS : ASW.Unbounded_Wide_String; + + Dot : constant ASW.Unbounded_Wide_String := + ASW.To_Unbounded_Wide_String(Equiv("Dot_")); + Dash : constant Wide_String := Equiv("Dash_"); + + Distress : ASW.Unbounded_Wide_String := + ASW."&"(ASW.To_Unbounded_Wide_String + (Equiv("Dot_Dot_Dot_")), + ASW."&"(ASW.To_Unbounded_Wide_String + (Equiv("Dash_Dash_Dash_")), + ASW.To_Unbounded_Wide_String + (Equiv("Dot_Dot_Dot")))); + + Repeat : constant Natural := 3; + Separator : constant Wide_Character := Equiv('_'); + + Separator_Set : Wide_Maps.Wide_Character_Set := + Wide_Maps.To_Set(Separator); + + begin + + -- Use the following constructor forms to construct the wide string + -- "Dot_Dot_Dot_Dash_Dash_Dash_Dot_Dot_Dot". Note that the + -- trailing underscore in the wide string is removed in the call to + -- Trim in the If statement condition. + + SOS := ASW."*"(Repeat, Dot); -- "*"(#, W Unb Str) + + SOS := ASW."&"(SOS, + ASW."&"(ASW."*"(Repeat, Dash), -- "*"(#, W Str) + ASW."*"(Repeat, Dot))); -- "*"(#, W Unb Str) + + if ASW.Trim(SOS, Wide_Maps.Null_Set, Separator_Set) /= Distress then + Report.Failed("Incorrect results from Function ""*"""); + end if; + + end Constructor_Block; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + + Report.Result; + +end CXA4023; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4024.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4024.a new file mode 100644 index 000000000..1b0af9ce9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4024.a @@ -0,0 +1,350 @@ +-- CXA4024.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_Ranges, To_Domain, and To_Range are +-- available in the package Ada.Strings.Maps, and that they produce +-- correct results based on the Character_Set/Character_Mapping input +-- provided. +-- +-- TEST DESCRIPTION: +-- This test examines the operation of four functions from within the +-- Ada.Strings.Maps package. A variety of Character_Sequence, +-- Character_Set, and Character_Mapping objects are created and +-- initialized for use with these functions. In each subtest of +-- function operation, specific inputs are provided to the functions as +-- input parameters, and the results are evaluated against expected +-- values. Wherever appropriate, additional characteristics of the +-- function results are verified against the prescribed result +-- characteristics. +-- +-- +-- CHANGE HISTORY: +-- 03 Feb 95 SAIC Initial prerelease version +-- 10 Mar 95 SAIC Incorporated reviewer comments. +-- 15 Apr 96 SAIC Incorporated reviewer comments for ACVC 2.1. +-- 05 Oct 96 SAIC Incorporated reviewer comments for ACVC 2.1. +-- +--! + +with Ada.Strings.Maps; +with Ada.Strings.Maps.Constants; +with Ada.Characters.Latin_1; +with Report; + +procedure CXA4024 is + +begin + + Report.Test ("CXA4024", "Check that the function ""-"", To_Ranges, " & + "To_Domain, and To_Range are available in " & + "the package Ada.Strings.Maps, and that " & + "they produce correct results"); + + Test_Block: + declare + + use Ada.Strings, Ada.Strings.Maps; + use type Maps.Character_Set; -- To allow logical set operator + -- infix notation. + package ACL1 renames Ada.Characters.Latin_1; + + MidPoint_Letter : constant := 13; + Last_Letter : constant := 26; + + Vowels : constant Maps.Character_Sequence := "aeiou"; + Quasi_Vowel : constant Character := 'y'; + + Alphabet : Maps.Character_Sequence (1..Last_Letter); + Half_Alphabet : Maps.Character_Sequence (1..MidPoint_Letter); + + Alphabet_Set, + Consonant_Set, + Vowel_Set, + First_Half_Set, + Second_Half_Set : Maps.Character_Set; + + + begin + + -- Load the alphabet strings for use in creating sets. + for i in 0..12 loop + Half_Alphabet(i+1) := Character'Val(Character'Pos('a') + i); + end loop; + + for i in 0..25 loop + Alphabet(i+1) := Character'Val(Character'Pos('a') + i); + end loop; + + -- Initialize a series of Character_Set objects. + + Alphabet_Set := Maps.To_Set(Alphabet); + Vowel_Set := Maps.To_Set(Vowels); + Consonant_Set := Vowel_Set XOR Alphabet_Set; + First_Half_Set := Maps.To_Set(Half_Alphabet); + Second_Half_Set := Alphabet_Set XOR First_Half_Set; + + + + -- Evaluation of Set operator "-". + + if Consonant_Set /= "-"(Alphabet_Set, Vowel_Set) or + Vowel_Set /= (Alphabet_Set - Consonant_Set) or + Alphabet_Set /= Alphabet_Set - Maps.Null_Set or + First_Half_Set /= "-"(Alphabet_Set, Second_Half_Set) or + (Alphabet_Set - Vowel_Set) /= "AND"(Alphabet_Set, "NOT"(Vowel_Set)) + then + Report.Failed("Incorrect result from ""-"" operator for sets"); + end if; + + + + -- Evaluation of Function "To_Ranges". + + declare + + use type Maps.Character_Range; + use type Maps.Character_Ranges; + + Set_A_to_C : Maps.Character_Set := Maps.To_Set("ABC"); + Set_J : Maps.Character_Set := Maps.To_Set("J"); + Set_M_to_P : Maps.Character_Set := Maps.To_Set("MNOP"); + Set_X_to_Z : Maps.Character_Set := Maps.To_Set("XYZ"); + Set_Of_Five : Maps.Character_Set := Set_A_to_C OR -- Union of the + Set_M_to_P OR -- five sets. + Set_X_to_Z OR + Set_J OR + Maps.Null_Set; + + TC_Range_A_to_C : Maps.Character_Range := (Low => 'A', High => 'C'); + TC_Range_J : Maps.Character_Range := ('J', 'J'); + TC_Range_M_to_P : Maps.Character_Range := ('M', 'P'); + TC_Range_X_to_Z : Maps.Character_Range := (Low => 'X', High => 'Z'); + + TC_Ranges : Maps.Character_Ranges (1..4) := + (1 => TC_Range_A_to_C, + 2 => TC_Range_J, + 3 => TC_Range_M_to_P, + 4 => TC_Range_X_to_Z); + + begin + + -- Based on input of a set containing four separate "spans" of + -- character sequences, Function To_Ranges is required to produce + -- the shortest array of contiguous ranges of Character values in + -- the input set, in increasing order of Low. + + declare + + -- This Character_Ranges constant should consist of array + -- components, each component being a Character_Range from Low + -- to High containing the appropriate characters. + + Ranges_Result : constant Maps.Character_Ranges := + Maps.To_Ranges(Set => Set_Of_Five); + begin + + -- Check the structure and components of the Character_Ranges + -- constant. + + if Ranges_Result(1) /= TC_Range_A_to_C or + Ranges_Result(1).Low /= TC_Ranges(1).Low or + Ranges_Result(2) /= TC_Range_J or + Ranges_Result(2).High /= TC_Ranges(2).High or + Ranges_Result(3) /= TC_Range_M_to_P or + Ranges_Result(3).Low /= TC_Ranges(3).Low or + Ranges_Result(3).High /= TC_Ranges(3).High or + Ranges_Result(4) /= TC_Range_X_To_Z or + Ranges_Result(4).Low /= TC_Ranges(4).Low or + Ranges_Result(4).High /= TC_Ranges(4).High + then + Report.Failed ("Incorrect structure or components in " & + "Character_Ranges constant"); + end if; + + exception + when others => + Report.Failed("Exception raised using the Function To_Ranges " & + "to initialize a Character_Ranges constant"); + end; + end; + + + + -- Evaluation of Functions To_Domain and To_Range. + + declare + + Null_Sequence : constant Maps.Character_Sequence := ""; + + TC_Upper_Case_Sequence : constant Maps.Character_Sequence := + "ZYXWVUTSRQPONMABCDEFGHIJKL"; + TC_Lower_Case_Sequence : constant Maps.Character_Sequence := + "zyxwvutsrqponmabcdefghijkl"; + TC_Unordered_Sequence : Maps.Character_Sequence(1..6) := + "BxACzy"; + + TC_Upper_to_Lower_Map : Maps.Character_Mapping := + Maps.To_Mapping(TC_Upper_Case_Sequence, + TC_Lower_Case_Sequence); + + TC_Lower_to_Upper_Map : Maps.Character_Mapping := + Maps.To_Mapping(TC_Lower_Case_Sequence, + TC_Upper_Case_Sequence); + + TC_Unordered_Map : Maps.Character_Mapping := + Maps.To_Mapping(TC_Unordered_Sequence, + "ikglja"); + begin + + declare + + TC_Domain_1 : constant Maps.Character_Sequence := + Maps.To_Domain(TC_Upper_to_Lower_Map); + + TC_Domain_2 : constant Maps.Character_Sequence := + Maps.To_Domain(TC_Lower_to_Upper_Map); + + TC_Domain_3 : Maps.Character_Sequence(1..6); + + TC_Range_1 : constant Maps.Character_Sequence := + Maps.To_Range(TC_Upper_to_Lower_Map); + + TC_Range_2 : constant Maps.Character_Sequence := + Maps.To_Range(TC_Lower_to_Upper_Map); + + TC_Range_3 : Maps.Character_Sequence(1..6); + + begin + + -- Function To_Domain returns the shortest Character_Sequence + -- value such that each character not in the result maps to + -- itself, and all characters in the result are in ascending + -- order. + + TC_Domain_3 := Maps.To_Domain(TC_Unordered_Map); + + -- Check contents of result of To_Domain, must be in ascending + -- order. + + if TC_Domain_1 /= "ABCDEFGHIJKLMNOPQRSTUVWXYZ" then + Report.Failed("Incorrect result from To_Domain with " & + "TC_Upper_to_Lower_Map as input"); + end if; + + if TC_Domain_2 /= "abcdefghijklmnopqrstuvwxyz" then + Report.Failed("Incorrect result from To_Domain with " & + "TC_Lower_to_Upper_Map as input"); + end if; + + if TC_Domain_3 /= "ABCxyz" then + Report.Failed("Incorrect result from To_Domain with " & + "an unordered mapping as input"); + end if; + + + -- The lower bound on the returned Character_Sequence value + -- from To_Domain must be 1. + + if TC_Domain_1'First /= 1 or + TC_Domain_2'First /= 1 or + TC_Domain_3'First /= 1 + then + Report.Failed("Incorrect lower bound returned from To_Domain"); + end if; + + + -- Check contents of result of To_Range. + + TC_Range_3 := Maps.To_Range(TC_Unordered_Map); + + if TC_Range_1 /= "abcdefghijklmnopqrstuvwxyz" then + Report.Failed("Incorrect result from To_Range with " & + "TC_Upper_to_Lower_Map as input"); + end if; + + if TC_Range_2 /= "ABCDEFGHIJKLMNOPQRSTUVWXYZ" then + Report.Failed("Incorrect result from To_Range with " & + "TC_Lower_to_Upper_Map as input"); + end if; + + if TC_Range_3 /= "gilkaj" then + Report.Failed("Incorrect result from To_Range with " & + "an unordered mapping as input"); + end if; + + + -- The lower bound on the returned Character_Sequence value + -- must be 1. + + if TC_Range_1'First /= 1 or + TC_Range_2'First /= 1 or + TC_Range_3'First /= 1 + then + Report.Failed("Incorrect lower bound returned from To_Range"); + end if; + + + -- The upper bound on the returned Character_Sequence value + -- must be Map'Length. + + if TC_Range_1'Last /= TC_Lower_Case_Sequence'Length or + TC_Range_2'Last /= TC_Upper_Case_Sequence'Length or + TC_Range_3'Last /= TC_Unordered_Sequence'Length + then + Report.Failed("Incorrect upper bound returned from To_Range"); + end if; + + end; + + -- Both function To_Domain and To_Range return the null string + -- when provided the Identity character map as an input parameter. + + if Maps.To_Domain(Maps.Identity) /= Null_Sequence then + Report.Failed("Function To_Domain did not return the null " & + "string when provided the Identity map as " & + "input"); + end if; + + if Maps.To_Range(Maps.Identity) /= Null_Sequence then + Report.Failed("Function To_Range did not return the null " & + "string when provided the Identity map as " & + "input"); + end if; + + exception + when others => + Report.Failed("Exception raised during the evaluation of " & + "Function To_Domain and To_Range"); + end; + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + + Report.Result; + +end CXA4024; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4025.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4025.a new file mode 100644 index 000000000..1665f7a46 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4025.a @@ -0,0 +1,376 @@ +-- CXA4025.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 functionality found in packages Ada.Strings.Wide_Maps, +-- Ada.Strings.Wide_Fixed, and Ada.Strings.Wide_Maps.Wide_Constants +-- is available and produces correct results. +-- +-- TEST DESCRIPTION: +-- This test validates the subprograms found in the various Wide_Map +-- and Wide_String packages. It is based on the tests CXA4024 and +-- CXA4026, which are tests for the complementary "non-wide" packages. +-- +-- The functions found in CXA4025_0 provide mapping capability, when +-- used in conjunction with Wide_Character_Mapping_Function objects. +-- +-- +-- CHANGE HISTORY: +-- 23 Jun 95 SAIC Initial prerelease version. +-- 15 Apr 96 SAIC Incorporated reviewer comments for ACVC 2.1. +-- +--! + +package CXA4025_0 is + -- Functions used to supply mapping capability. + function Map_To_Lower_Case (From : Wide_Character) return Wide_Character; + function Map_To_Upper_Case (From : Wide_Character) return Wide_Character; +end CXA4025_0; + +with Ada.Characters.Handling; +package body CXA4025_0 is + -- Function Map_To_Lower_Case will return the lower case form of + -- Wide_Characters in the range 'A'..'Z' only, and return the input + -- wide_character otherwise. + + function Map_To_Lower_Case (From : Wide_Character) + return Wide_Character is + begin + return Ada.Characters.Handling.To_Wide_Character( + Ada.Characters.Handling.To_Lower( + Ada.Characters.Handling.To_Character(From))); + end Map_To_Lower_Case; + + -- Function Map_To_Upper_Case will return the upper case form of + -- Wide_Characters in the range 'a'..'z', or whose position is in one + -- of the ranges 223..246 or 248..255, provided the wide_character has + -- an upper case form. + + function Map_To_Upper_Case (From : Wide_Character) + return Wide_Character is + begin + return Ada.Characters.Handling.To_Wide_Character( + Ada.Characters.Handling.To_Upper( + Ada.Characters.Handling.To_Character(From))); + end Map_To_Upper_Case; + +end CXA4025_0; + + +with CXA4025_0; +with Report; +with Ada.Characters.Handling; +with Ada.Characters.Latin_1; +with Ada.Exceptions; +with Ada.Strings; +with Ada.Strings.Wide_Maps; +with Ada.Strings.Wide_Maps.Wide_Constants; +with Ada.Strings.Wide_Fixed; + +procedure CXA4025 is +begin + Report.Test ("CXA4025", + "Check that subprograms defined in packages " & + "Ada.Strings.Wide_Maps and Ada.Strings.Wide_Fixed " & + "produce correct results"); + + Test_Block: + declare + + package ACL1 renames Ada.Characters.Latin_1; + + use Ada.Characters, Ada.Strings; + use Ada.Exceptions; + use type Wide_Maps.Wide_Character_Set; + + subtype LC_Characters is Wide_Character range 'a'..'z'; + + Last_Letter : constant := 26; + Vowels : constant Wide_Maps.Wide_Character_Sequence := "aeiou"; + TC_String : constant Wide_String := "A Standard String"; + + Alphabet : Wide_Maps.Wide_Character_Sequence (1..Last_Letter); + Alphabet_Set, + Consonant_Set, + Vowel_Set : Wide_Maps.Wide_Character_Set; + + String_20 : Wide_String(1..20) := "ABCDEFGHIJKLMNOPQRST"; + String_40 : Wide_String(1..40) := "abcdefghijklmnopqrst" & + String_20; + String_80 : Wide_String(1..80) := String_40 & String_40; + TC_String_5 : Wide_String(1..5) := "ABCDE"; + + -- The following strings are used in examination of the Translation + -- subprograms. + New_Character_String : Wide_String(1..12) := + Handling.To_Wide_String( + ACL1.LC_A_Grave & ACL1.LC_A_Ring & ACL1.LC_AE_Diphthong & + ACL1.LC_C_Cedilla & ACL1.LC_E_Acute & ACL1.LC_I_Circumflex & + ACL1.LC_Icelandic_Eth & ACL1.LC_N_Tilde & + ACL1.LC_O_Oblique_Stroke & ACL1.LC_Icelandic_Thorn & + ACL1.LC_German_Sharp_S & ACL1.LC_Y_Diaeresis); + + -- Note that there is no upper case version of the last two + -- characters from above. + + TC_New_Character_String : Wide_String(1..12) := + Handling.To_Wide_String( + ACL1.UC_A_Grave & ACL1.UC_A_Ring & ACL1.UC_AE_Diphthong & + ACL1.UC_C_Cedilla & ACL1.UC_E_Acute & ACL1.UC_I_Circumflex & + ACL1.UC_Icelandic_Eth & ACL1.UC_N_Tilde & + ACL1.UC_O_Oblique_Stroke & ACL1.UC_Icelandic_Thorn & + ACL1.LC_German_Sharp_S & ACL1.LC_Y_Diaeresis); + + -- Access objects that will be provided as parameters to the + -- subprograms. + Map_To_Lower_Case_Ptr : Wide_Maps.Wide_Character_Mapping_Function := + CXA4025_0.Map_To_Lower_Case'Access; + Map_To_Upper_Case_Ptr : Wide_Maps.Wide_Character_Mapping_Function := + CXA4025_0.Map_To_Upper_Case'Access; + + begin + + -- + -- Testing of functionality found in Package Ada.Strings.Wide_Maps. + -- + + -- Load the alphabet strings for use in creating sets. + for i in 0..25 loop + Alphabet(i+1) := Wide_Character'Val(Wide_Character'Pos('a')+i); + end loop; + + -- Initialize a series of Character_Set objects. + Alphabet_Set := Wide_Maps.To_Set(Alphabet); + Vowel_Set := Wide_Maps.To_Set(Vowels); + Consonant_Set := Vowel_Set XOR Alphabet_Set; + + -- Evaluation of Set operator "-". + if + (Alphabet_Set - Consonant_Set) /= + "AND"(Alphabet_Set, "NOT"(Consonant_Set)) or + (Alphabet_Set - Vowel_Set) /= "AND"(Alphabet_Set, "NOT"(Vowel_Set)) + then + Report.Failed("Incorrect result from ""-"" operator for sets"); + end if; + + -- Evaluation of Functions To_Domain and To_Range. + declare + Null_Sequence : constant Wide_Maps.Wide_Character_Sequence := ""; + TC_UC_Sequence : constant Wide_Maps.Wide_Character_Sequence := + "ZYXWVUTSRQPONMABCDEFGHIJKL"; + TC_LC_Sequence : constant Wide_Maps.Wide_Character_Sequence := + "zyxwvutsrqponmabcdefghijkl"; + TC_Upper_to_Lower_Map : Wide_Maps.Wide_Character_Mapping := + Wide_Maps.To_Mapping(TC_UC_Sequence, + TC_LC_Sequence); + TC_Lower_to_Upper_Map : Wide_Maps.Wide_Character_Mapping := + Wide_Maps.To_Mapping(TC_LC_Sequence, + TC_UC_Sequence); + begin + declare + TC_Domain : constant Wide_Maps.Wide_Character_Sequence := + Wide_Maps.To_Domain(TC_Upper_to_Lower_Map); + TC_Range : constant Wide_Maps.Wide_Character_Sequence := + Wide_Maps.To_Range(TC_Lower_to_Upper_Map); + begin + -- Function To_Domain returns the shortest Wide_Character_Sequence + -- value such that each wide character not in the result maps to + -- itself, and all wide characters in the result are in ascending + -- order. + if TC_Domain /= "ABCDEFGHIJKLMNOPQRSTUVWXYZ" then + Report.Failed("Incorrect result from To_Domain with " & + "TC_Upper_to_Lower_Map as input"); + end if; + + -- The lower bound on the returned Wide_Character_Sequence value + -- from To_Domain must be 1. + if TC_Domain'First /= 1 then + Report.Failed("Incorrect lower bound returned from To_Domain"); + end if; + + -- Check contents of result of To_Range. + if TC_Range /= "ABCDEFGHIJKLMNOPQRSTUVWXYZ" then + Report.Failed("Incorrect result from To_Range with " & + "TC_Lower_to_Upper_Map as input"); + end if; + + -- The lower bound on the returned Character_Sequence value + -- must be 1. + if TC_Range'First /= 1 then + Report.Failed("Incorrect lower bound returned from To_Range"); + end if; + + if TC_Range'Last /= TC_LC_Sequence'Length then + Report.Failed("Incorrect upper bound returned from To_Range"); + end if; + end; + + -- Both function To_Domain and To_Range return the null string + -- when provided the Identity character map as an input parameter. + if Wide_Maps.To_Domain(Wide_Maps.Identity) /= Null_Sequence or + Wide_Maps.To_Range(Wide_Maps.Identity) /= Null_Sequence + then + Report.Failed("Null sequence not returned from To_Domain or " & + "To_Range when provided the Identity map as input"); + end if; + exception + when others => + Report.Failed("Exception raised during the evaluation of " & + "Function To_Domain and To_Range"); + end; + + -- Testing of functionality found in Package Ada.Strings.Wide_Fixed. + -- + -- Function Index, Forward direction search. + + if Wide_Fixed.Index("CoMpLeTeLy MiXeD CaSe StRiNg", + "MIXED CASE STRING", + Ada.Strings.Forward, + Map_To_Upper_Case_Ptr) /= 12 or + Wide_Fixed.Index("STRING WITH NO MATCHING PATTERNS", + "WITH", + Ada.Strings.Forward, + Map_To_Lower_Case_Ptr) /= 0 + then + Report.Failed("Incorrect results from Function Index, going " & + "in Forward direction, using a Character Mapping " & + "Function parameter"); + end if; + + -- Function Index, Backward direction search. + if Wide_Fixed.Index("Case of a Mixed Case String", + "case", + Ada.Strings.Backward, + Map_To_Lower_Case_Ptr) /= 17 or + Wide_Fixed.Index("WOULD MATCH BUT FOR THE CASE", + "WOULD MATCH BUT FOR THE CASE", + Ada.Strings.Backward, + Map_To_Lower_Case_Ptr) /= 0 + then + Report.Failed("Incorrect results from Function Index, going " & + "in Backward direction, using a Character Mapping " & + "Function parameter"); + end if; + + -- Function Count. + if Wide_Fixed.Count("ABABABA", "ABA", Map_To_Upper_Case_Ptr) /= 2 or + Wide_Fixed.Count("", "match", Map_To_Lower_Case_Ptr) /= 0 + then + Report.Failed("Incorrect results from Function Count, using " & + "a Character Mapping Function parameter"); + end if; + + -- Function Translate. + if Wide_Fixed.Translate(Source => "A Sample Mixed Case String", + Mapping => Map_To_Lower_Case_Ptr) /= + "a sample mixed case string" or + Wide_Fixed.Translate(New_Character_String, + Map_To_Upper_Case_Ptr) /= + TC_New_Character_String + then + Report.Failed("Incorrect results from Function Translate, using " & + "a Wide_Character Mapping Function parameter"); + end if; + + -- Procedure Translate. + declare + use Ada.Strings.Wide_Fixed; + Str : Wide_String(1..19) := "A Mixed Case String"; + begin + Translate(Source => Str, Mapping => Map_To_Lower_Case_Ptr); + if Str /= "a mixed case string" then + Report.Failed("Incorrect result from Procedure Translate - 1"); + end if; + + Translate(New_Character_String, Map_To_Upper_Case_Ptr); + if New_Character_String /= TC_New_Character_String then + Report.Failed("Incorrect result from Procedure Translate - 2"); + end if; + end; + + -- Procedure Trim. + declare + use Ada.Strings.Wide_Fixed; + Trim_String : Wide_String(1..30) := " A string of characters "; + begin + Trim(Trim_String, Ada.Strings.Left, Ada.Strings.Right, 'x'); + if Trim_String /= "xxxxA string of characters " then + Report.Failed("Incorrect result from Procedure Trim, trim " & + "side = left, justify = right, pad = x"); + end if; + + Trim(Trim_String, Ada.Strings.Right, Ada.Strings.Center); + if Trim_String /= " xxxxA string of characters " then + Report.Failed("Incorrect result from Procedure Trim, trim " & + "side = right, justify = center, default pad"); + end if; + end; + + -- Procedure Head. + declare + Fixed_String : Wide_String(1..20) := "A sample test string"; + begin + Wide_Fixed.Head(Source => Fixed_String, Count => 14, + Justify => Ada.Strings.Center, Pad => '$'); + if Fixed_String /= "$$$A sample test $$$" then + Report.Failed("Incorrect result from Procedure Head, " & + "justify = center, pad = $"); + end if; + + Wide_Fixed.Head(Fixed_String, 11, Ada.Strings.Right); + if Fixed_String /= " $$$A sample" then + Report.Failed("Incorrect result from Procedure Head, " & + "justify = right, default pad"); + end if; + end; + + -- Procedure Tail. + declare + use Ada.Strings.Wide_Fixed; + Tail_String : Wide_String(1..20) := "ABCDEFGHIJKLMNOPQRST"; + begin + -- Default left justify. + Tail(Source => Tail_String, Count => 10, Pad => '-'); + if Tail_String /= "KLMNOPQRST----------" then + Report.Failed("Incorrect result from Procedure Tail, " & + "default justify, pad = -"); + end if; + + Tail(Tail_String, 6, Ada.Strings.Center, 'a'); + if Tail_String /= "aaaaaaa------aaaaaaa" then + Report.Failed("Incorrect result from Procedure Tail, " & + "justify = center, pad = a"); + end if; + 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 CXA4025; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4026.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4026.a new file mode 100644 index 000000000..766979ad0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4026.a @@ -0,0 +1,526 @@ +-- CXA4026.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 Ada.Strings.Fixed procedures Head, Tail, and Trim, as well +-- as the versions of subprograms Translate (procedure and function), +-- Index, and Count, available in the package which use a +-- Maps.Character_Mapping_Function input parameter, produce correct +-- results. +-- +-- TEST DESCRIPTION: +-- This test examines the operation of several subprograms contained in +-- the Ada.Strings.Fixed package. +-- This includes procedure versions of Head, Tail, and Trim, as well as +-- four subprograms that use a Character_Mapping_Function as a parameter +-- to provide the mapping capability. +-- +-- Two functions are defined to provide the mapping. Access values +-- are defined to refer to these functions. One of the functions will +-- map upper case characters in the range 'A'..'Z' to their lower case +-- counterparts, while the other function will map lower case characters +-- ('a'..'z', or a character whose position is in one of the ranges +-- 223..246 or 248..255, provided the character has an upper case form) +-- to their upper case form. +-- +-- Function Index uses the mapping function access value to map the input +-- string prior to searching for the appropriate index value to return. +-- Function Count uses the mapping function access value to map the input +-- string prior to counting the occurrences of the pattern string. +-- Both the Procedure and Function version of Translate use the mapping +-- function access value to perform the translation. +-- +-- Results of all subprograms are compared with expected results. +-- +-- +-- CHANGE HISTORY: +-- 10 Feb 95 SAIC Initial prerelease version +-- 21 Apr 95 SAIC Modified definition of string variable Str_2. +-- +--! + + +package CXA4026_0 is + + -- Function Map_To_Lower_Case will return the lower case form of + -- Characters in the range 'A'..'Z' only, and return the input + -- character otherwise. + + function Map_To_Lower_Case (From : Character) return Character; + + + -- Function Map_To_Upper_Case will return the upper case form of + -- Characters in the range 'a'..'z', or whose position is in one + -- of the ranges 223..246 or 248..255, provided the character has + -- an upper case form. + + function Map_To_Upper_Case (From : Character) return Character; + +end CXA4026_0; + + +with Ada.Characters.Handling; +package body CXA4026_0 is + + function Map_To_Lower_Case (From : Character) return Character is + begin + if From in 'A'..'Z' then + return Character'Val(Character'Pos(From) - + (Character'Pos('A') - Character'Pos('a'))); + else + return From; + end if; + end Map_To_Lower_Case; + + function Map_To_Upper_Case (From : Character) return Character is + begin + return Ada.Characters.Handling.To_Upper(From); + end Map_To_Upper_Case; + +end CXA4026_0; + + +with CXA4026_0; +with Ada.Strings.Fixed; +with Ada.Strings.Maps; +with Ada.Characters.Handling; +with Ada.Characters.Latin_1; +with Report; + +procedure CXA4026 is + +begin + + Report.Test ("CXA4026", "Check that procedures Trim, Head, and Tail, " & + "as well as the versions of subprograms " & + "Translate, Index, and Count, which use the " & + "Character_Mapping_Function input parameter," & + "produce correct results"); + + Test_Block: + declare + + use Ada.Strings, CXA4026_0; + + -- The following strings are used in examination of the Translation + -- subprograms. + + New_Character_String : String(1..10) := + Ada.Characters.Latin_1.LC_A_Grave & + Ada.Characters.Latin_1.LC_A_Ring & + Ada.Characters.Latin_1.LC_AE_Diphthong & + Ada.Characters.Latin_1.LC_C_Cedilla & + Ada.Characters.Latin_1.LC_E_Acute & + Ada.Characters.Latin_1.LC_I_Circumflex & + Ada.Characters.Latin_1.LC_Icelandic_Eth & + Ada.Characters.Latin_1.LC_N_Tilde & + Ada.Characters.Latin_1.LC_O_Oblique_Stroke & + Ada.Characters.Latin_1.LC_Icelandic_Thorn; + + + TC_New_Character_String : String(1..10) := + Ada.Characters.Latin_1.UC_A_Grave & + Ada.Characters.Latin_1.UC_A_Ring & + Ada.Characters.Latin_1.UC_AE_Diphthong & + Ada.Characters.Latin_1.UC_C_Cedilla & + Ada.Characters.Latin_1.UC_E_Acute & + Ada.Characters.Latin_1.UC_I_Circumflex & + Ada.Characters.Latin_1.UC_Icelandic_Eth & + Ada.Characters.Latin_1.UC_N_Tilde & + Ada.Characters.Latin_1.UC_O_Oblique_Stroke & + Ada.Characters.Latin_1.UC_Icelandic_Thorn; + + + -- Functions used to supply mapping capability. + + + -- Access objects that will be provided as parameters to the + -- subprograms. + + Map_To_Lower_Case_Ptr : Maps.Character_Mapping_Function := + Map_To_Lower_Case'Access; + + Map_To_Upper_Case_Ptr : Maps.Character_Mapping_Function := + Map_To_Upper_Case'Access; + + + begin + + -- Function Index, Forward direction search. + -- Note: Several of the following cases use the default value + -- Forward for the Going parameter. + + if Fixed.Index(Source => "The library package Strings.Fixed", + Pattern => "fix", + Going => Ada.Strings.Forward, + Mapping => Map_To_Lower_Case_Ptr) /= 29 or + Fixed.Index("THE RAIN IN SPAIN FALLS MAINLY ON THE PLAIN", + "ain", + Mapping => Map_To_Lower_Case_Ptr) /= 6 or + Fixed.Index("maximum number", + "um", + Ada.Strings.Forward, + Map_To_Lower_Case_Ptr) /= 6 or + Fixed.Index("CoMpLeTeLy MiXeD CaSe StRiNg", + "MIXED CASE STRING", + Ada.Strings.Forward, + Map_To_Upper_Case_Ptr) /= 12 or + Fixed.Index("STRING WITH NO MATCHING PATTERNS", + "WITH", + Ada.Strings.Forward, + Map_To_Lower_Case_Ptr) /= 0 or + Fixed.Index("THIS STRING IS IN UPPER CASE", + "IS", + Ada.Strings.Forward, + Map_To_Upper_Case_Ptr) /= 3 or + Fixed.Index("", -- Null string. + "is", + Mapping => Map_To_Lower_Case_Ptr) /= 0 or + Fixed.Index("AAABBBaaabbb", + "aabb", + Mapping => Map_To_Lower_Case_Ptr) /= 2 + then + Report.Failed("Incorrect results from Function Index, going " & + "in Forward direction, using a Character Mapping " & + "Function parameter"); + end if; + + + + -- Function Index, Backward direction search. + + if Fixed.Index("Case of a Mixed Case String", + "case", + Ada.Strings.Backward, + Map_To_Lower_Case_Ptr) /= 17 or + Fixed.Index("Case of a Mixed Case String", + "CASE", + Ada.Strings.Backward, + Map_To_Upper_Case_Ptr) /= 17 or + Fixed.Index("rain, Rain, and more RAIN", + "rain", + Ada.Strings.Backward, + Map_To_Lower_Case_Ptr) /= 22 or + Fixed.Index("RIGHT place, right time", + "RIGHT", + Ada.Strings.Backward, + Map_To_Upper_Case_Ptr) /= 14 or + Fixed.Index("WOULD MATCH BUT FOR THE CASE", + "WOULD MATCH BUT FOR THE CASE", + Ada.Strings.Backward, + Map_To_Lower_Case_Ptr) /= 0 + then + Report.Failed("Incorrect results from Function Index, going " & + "in Backward direction, using a Character Mapping " & + "Function parameter"); + end if; + + + + -- Function Index, Pattern_Error if Pattern = Null_String + + declare + use Ada.Strings.Fixed; + Null_Pattern_String : constant String := ""; + TC_Natural : Natural := 1000; + begin + TC_Natural := Index("A Valid String", + Null_Pattern_String, + Ada.Strings.Forward, + Map_To_Lower_Case_Ptr); + Report.Failed("Pattern_Error not raised by Function Index when " & + "given a null pattern string"); + exception + when Pattern_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by Function Index " & + "using a Character Mapping Function parameter " & + "when given a null pattern string"); + end; + + + + -- Function Count. + + if Fixed.Count(Source => "ABABABA", + Pattern => "aba", + Mapping => Map_To_Lower_Case_Ptr) /= 2 or + Fixed.Count("ABABABA", "ABA", Map_To_Lower_Case_Ptr) /= 0 or + Fixed.Count("This IS a MISmatched issue", + "is", + Map_To_Lower_Case_Ptr) /= 4 or + Fixed.Count("ABABABA", "ABA", Map_To_Upper_Case_Ptr) /= 2 or + Fixed.Count("This IS a MISmatched issue", + "is", + Map_To_Upper_Case_Ptr) /= 0 or + Fixed.Count("She sells sea shells by the sea shore", + "s", + Map_To_Lower_Case_Ptr) /= 8 or + Fixed.Count("", -- Null string. + "match", + Map_To_Upper_Case_Ptr) /= 0 + then + Report.Failed("Incorrect results from Function Count, using " & + "a Character Mapping Function parameter"); + end if; + + + + -- Function Count, Pattern_Error if Pattern = Null_String + + declare + use Ada.Strings.Fixed; + Null_Pattern_String : constant String := ""; + TC_Natural : Natural := 1000; + begin + TC_Natural := Count("A Valid String", + Null_Pattern_String, + Map_To_Lower_Case_Ptr); + Report.Failed("Pattern_Error not raised by Function Count using " & + "a Character Mapping Function parameter when " & + "given a null pattern string"); + exception + when Pattern_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by Function Count " & + "using a Character Mapping Function parameter " & + "when given a null pattern string"); + end; + + + + -- Function Translate. + + if Fixed.Translate(Source => "A Sample Mixed Case String", + Mapping => Map_To_Lower_Case_Ptr) /= + "a sample mixed case string" or + + Fixed.Translate("ALL LOWER CASE", + Map_To_Lower_Case_Ptr) /= + "all lower case" or + + Fixed.Translate("end with lower case", + Map_To_Lower_Case_Ptr) /= + "end with lower case" or + + Fixed.Translate("", Map_To_Lower_Case_Ptr) /= + "" or + + Fixed.Translate("start with lower case", + Map_To_Upper_Case_Ptr) /= + "START WITH LOWER CASE" or + + Fixed.Translate("ALL UPPER CASE STRING", + Map_To_Upper_Case_Ptr) /= + "ALL UPPER CASE STRING" or + + Fixed.Translate("LoTs Of MiXeD CaSe ChArAcTeRs", + Map_To_Upper_Case_Ptr) /= + "LOTS OF MIXED CASE CHARACTERS" or + + Fixed.Translate("", Map_To_Upper_Case_Ptr) /= + "" or + + Fixed.Translate(New_Character_String, + Map_To_Upper_Case_Ptr) /= + TC_New_Character_String + then + Report.Failed("Incorrect results from Function Translate, using " & + "a Character Mapping Function parameter"); + end if; + + + + -- Procedure Translate. + + declare + + use Ada.Strings.Fixed; + + Str_1 : String(1..24) := "AN ALL UPPER CASE STRING"; + Str_2 : String(1..19) := "A Mixed Case String"; + Str_3 : String(1..32) := "a string with lower case letters"; + TC_Str_1 : constant String := Str_1; + TC_Str_3 : constant String := Str_3; + + begin + + Translate(Source => Str_1, Mapping => Map_To_Lower_Case_Ptr); + + if Str_1 /= "an all upper case string" then + Report.Failed("Incorrect result from Procedure Translate - 1"); + end if; + + Translate(Source => Str_1, Mapping => Map_To_Upper_Case_Ptr); + + if Str_1 /= TC_Str_1 then + Report.Failed("Incorrect result from Procedure Translate - 2"); + end if; + + Translate(Source => Str_2, Mapping => Map_To_Lower_Case_Ptr); + + if Str_2 /= "a mixed case string" then + Report.Failed("Incorrect result from Procedure Translate - 3"); + end if; + + Translate(Source => Str_2, Mapping => Map_To_Upper_Case_Ptr); + + if Str_2 /= "A MIXED CASE STRING" then + Report.Failed("Incorrect result from Procedure Translate - 4"); + end if; + + Translate(Source => Str_3, Mapping => Map_To_Lower_Case_Ptr); + + if Str_3 /= TC_Str_3 then + Report.Failed("Incorrect result from Procedure Translate - 5"); + end if; + + Translate(Source => Str_3, Mapping => Map_To_Upper_Case_Ptr); + + if Str_3 /= "A STRING WITH LOWER CASE LETTERS" then + Report.Failed("Incorrect result from Procedure Translate - 6"); + end if; + + Translate(New_Character_String, Map_To_Upper_Case_Ptr); + + if New_Character_String /= TC_New_Character_String then + Report.Failed("Incorrect result from Procedure Translate - 6"); + end if; + + end; + + + -- Procedure Trim. + + declare + Use Ada.Strings.Fixed; + Trim_String : String(1..30) := " A string of characters "; + begin + + Trim(Source => Trim_String, + Side => Ada.Strings.Left, + Justify => Ada.Strings.Right, + Pad => 'x'); + + if Trim_String /= "xxxxA string of characters " then + Report.Failed("Incorrect result from Procedure Trim, trim " & + "side = left, justify = right, pad = x"); + end if; + + Trim(Trim_String, Ada.Strings.Right, Ada.Strings.Center); + + if Trim_String /= " xxxxA string of characters " then + Report.Failed("Incorrect result from Procedure Trim, trim " & + "side = right, justify = center, default pad"); + end if; + + Trim(Trim_String, Ada.Strings.Both, Pad => '*'); + + if Trim_String /= "xxxxA string of characters****" then + Report.Failed("Incorrect result from Procedure Trim, trim " & + "side = both, default justify, pad = *"); + end if; + + end; + + + -- Procedure Head. + + declare + Fixed_String : String(1..20) := "A sample test string"; + begin + + Fixed.Head(Source => Fixed_String, + Count => 14, + Justify => Ada.Strings.Center, + Pad => '$'); + + if Fixed_String /= "$$$A sample test $$$" then + Report.Failed("Incorrect result from Procedure Head, " & + "justify = center, pad = $"); + end if; + + Fixed.Head(Fixed_String, 11, Ada.Strings.Right); + + if Fixed_String /= " $$$A sample" then + Report.Failed("Incorrect result from Procedure Head, " & + "justify = right, default pad"); + end if; + + Fixed.Head(Fixed_String, 9, Pad => '*'); + + if Fixed_String /= " ***********" then + Report.Failed("Incorrect result from Procedure Head, " & + "default justify, pad = *"); + end if; + + end; + + + -- Procedure Tail. + + declare + Use Ada.Strings.Fixed; + Tail_String : String(1..20) := "ABCDEFGHIJKLMNOPQRST"; + begin + + Tail(Source => Tail_String, Count => 10, Pad => '-'); + + if Tail_String /= "KLMNOPQRST----------" then + Report.Failed("Incorrect result from Procedure Tail, " & + "default justify, pad = -"); + end if; + + Tail(Tail_String, 6, Justify => Ada.Strings.Center, Pad => 'a'); + + if Tail_String /= "aaaaaaa------aaaaaaa" then + Report.Failed("Incorrect result from Procedure Tail, " & + "justify = center, pad = a"); + end if; + + Tail(Tail_String, 1, Ada.Strings.Right); + + if Tail_String /= " a" then + Report.Failed("Incorrect result from Procedure Tail, " & + "justify = right, default pad"); + end if; + + Tail(Tail_String, 19, Ada.Strings.Right, 'A'); + + if Tail_String /= "A a" then + Report.Failed("Incorrect result from Procedure Tail, " & + "justify = right, pad = A"); + end if; + + end; + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + + Report.Result; + +end CXA4026; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4027.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4027.a new file mode 100644 index 000000000..05c66d4cc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4027.a @@ -0,0 +1,342 @@ +-- CXA4027.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 versions of Ada.Strings.Bounded subprograms Translate, +-- (procedure and function), Index, and Count, which use the +-- Maps.Character_Mapping_Function input parameter, produce correct +-- results. +-- +-- TEST DESCRIPTION: +-- This test examines the operation of several subprograms from within +-- the Ada.Strings.Bounded package that use the +-- Character_Mapping_Function mapping parameter to provide a mapping +-- capability. +-- +-- Two functions are defined to provide the mapping. Access values +-- are defined to refer to these functions. One of the functions will +-- map upper case characters in the range 'A'..'Z' to their lower case +-- counterparts, while the other function will map lower case characters +-- ('a'..'z', or a character whose position is in one of the ranges +-- 223..246 or 248..255, provided the character has an upper case form) +-- to their upper case form. +-- +-- Function Index uses the mapping function access value to map the input +-- string prior to searching for the appropriate index value to return. +-- Function Count uses the mapping function access value to map the input +-- string prior to counting the occurrences of the pattern string. +-- Both the Procedure and Function version of Translate use the mapping +-- function access value to perform the translation. +-- +-- +-- CHANGE HISTORY: +-- 16 FEB 95 SAIC Initial prerelease version +-- 17 Jul 95 SAIC Incorporated reviewer comments. Replaced two +-- internally declared functions with two library +-- level functions to eliminate accessibility +-- problems. +-- +--! + + +-- Function CXA4027_0 will return the lower case form of +-- the character input if it is in upper case, and return the input +-- character otherwise. + +with Ada.Characters.Handling; +function CXA4027_0 (From : Character) return Character; + +function CXA4027_0 (From : Character) return Character is +begin + return Ada.Characters.Handling.To_Lower(From); +end CXA4027_0; + + + +-- Function CXA4027_1 will return the upper case form of +-- Characters in the range 'a'..'z', or whose position is in one +-- of the ranges 223..246 or 248..255, provided the character has +-- an upper case form. + +with Ada.Characters.Handling; +function CXA4027_1 (From : Character) return Character; + +function CXA4027_1 (From : Character) return Character is +begin + return Ada.Characters.Handling.To_Upper(From); +end CXA4027_1; + + +with CXA4027_0, CXA4027_1; +with Ada.Strings.Bounded; +with Ada.Strings.Maps; +with Ada.Characters.Handling; +with Report; + +procedure CXA4027 is +begin + + Report.Test ("CXA4027", "Check that Ada.Strings.Bounded subprograms " & + "Translate, Index, and Count, which use the " & + "Character_Mapping_Function input parameter, " & + "produce correct results"); + + Test_Block: + declare + + use Ada.Strings; + + -- Functions used to supply mapping capability. + + function Map_To_Lower_Case (From : Character) return Character + renames CXA4027_0; + + function Map_To_Upper_Case (From : Character) return Character + renames CXA4027_1; + + Map_To_Lower_Case_Ptr : Maps.Character_Mapping_Function := + Map_To_Lower_Case'Access; + + Map_To_Upper_Case_Ptr : Maps.Character_Mapping_Function := + Map_To_Upper_Case'Access; + + + -- Instantiations of Bounded String generic package. + + package BS1 is new Ada.Strings.Bounded.Generic_Bounded_Length(1); + package BS20 is new Ada.Strings.Bounded.Generic_Bounded_Length(20); + package BS40 is new Ada.Strings.Bounded.Generic_Bounded_Length(40); + package BS80 is new Ada.Strings.Bounded.Generic_Bounded_Length(80); + + use type BS1.Bounded_String, BS20.Bounded_String, + BS40.Bounded_String, BS80.Bounded_String; + + String_1 : String(1..1) := "A"; + String_20 : String(1..20) := "ABCDEFGHIJKLMNOPQRST"; + String_40 : String(1..40) := "abcdefghijklmnopqrst" & String_20; + String_80 : String(1..80) := String_40 & String_40; + + BString_1 : BS1.Bounded_String := BS1.Null_Bounded_String; + BString_20 : BS20.Bounded_String := BS20.Null_Bounded_String; + BString_40 : BS40.Bounded_String := BS40.Null_Bounded_String; + BString_80 : BS80.Bounded_String := BS80.Null_Bounded_String; + + + begin + + -- Function Index. + + if BS40.Index(BS40.To_Bounded_String("Package Strings.Bounded"), + Pattern => "s.b", + Going => Ada.Strings.Forward, + Mapping => Map_To_Lower_Case_Ptr) /= 15 or + BS80.Index(BS80.To_Bounded_String("STRING TRANSLATIONS SUBPROGRAMS"), + "tr", + Mapping => Map_To_Lower_Case_Ptr) /= 2 or + BS20.Index(BS20.To_Bounded_String("maximum number"), + "um", + Ada.Strings.Backward, + Map_To_Lower_Case_Ptr) /= 10 or + BS80.Index(BS80.To_Bounded_String("CoMpLeTeLy MiXeD CaSe StRiNg"), + "MIXED CASE STRING", + Ada.Strings.Forward, + Map_To_Upper_Case_Ptr) /= 12 or + BS40.Index(BS40.To_Bounded_String("STRING WITH NO MATCHING PATTERN"), + "WITH", + Ada.Strings.Backward, + Map_To_Lower_Case_Ptr) /= 0 or + BS80.Index(BS80.To_Bounded_String("THIS STRING IS IN UPPER CASE"), + "I", + Ada.Strings.Backward, + Map_To_Upper_Case_Ptr) /= 16 or + BS1.Index(BS1.Null_Bounded_String, + "i", + Mapping => Map_To_Lower_Case_Ptr) /= 0 or + BS40.Index(BS40.To_Bounded_String("AAABBBaaabbb"), + "aabb", + Mapping => Map_To_Lower_Case_Ptr) /= 2 or + BS80.Index(BS80.To_Bounded_String("WOULD MATCH BUT FOR THE CASE"), + "WOULD MATCH BUT FOR THE CASE", + Ada.Strings.Backward, + Map_To_Lower_Case_Ptr) /= 0 + then + Report.Failed("Incorrect results from Function Index, using a " & + "Character Mapping Function parameter"); + end if; + + + -- Function Index, Pattern_Error if Pattern = Null_String + + declare + use BS20; + TC_Natural : Natural := 1000; + begin + TC_Natural := Index(To_Bounded_String("A Valid String"), + "", + Ada.Strings.Forward, + Map_To_Lower_Case_Ptr); + Report.Failed("Pattern_Error not raised by Function Index when " & + "given a null pattern string"); + exception + when Pattern_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by Function Index " & + "using a Character_Mapping_Function parameter " & + "when given a null pattern string"); + end; + + + -- Function Count. + + if BS20.Count(BS20.To_Bounded_String("ABABABA"), + Pattern => "aba", + Mapping => Map_To_Lower_Case_Ptr) /= 2 or + BS20.Count(BS20.To_Bounded_String("ABABABA"), + "ABA", + Map_To_Lower_Case_Ptr) /= 0 or + BS40.Count(BS40.To_Bounded_String("This IS a MISmatched issue"), + "is", + Map_To_Lower_Case_Ptr) /= 4 or + BS80.Count(BS80.To_Bounded_String("ABABABA"), + "ABA", + Map_To_Upper_Case_Ptr) /= 2 or + BS40.Count(BS40.To_Bounded_String("This IS a MISmatched issue"), + "is", + Map_To_Upper_Case_Ptr) /= 0 or + BS80.Count(BS80.To_Bounded_String + ("Peter Piper and his Pickled Peppers"), + "p", + Map_To_Lower_Case_Ptr) /= 7 or + BS20.Count(BS20.To_Bounded_String("She sells sea shells"), + "s", + Map_To_Upper_Case_Ptr) /= 0 or + BS80.Count(BS80.To_Bounded_String("No matches what-so-ever"), + "matches", + Map_To_Upper_Case_Ptr) /= 0 + then + Report.Failed("Incorrect results from Function Count, using " & + "a Character_Mapping_Function parameter"); + end if; + + + -- Function Count, Pattern_Error if Pattern = Null_String + + declare + use BS80; + TC_Natural : Natural := 1000; + begin + TC_Natural := Count(To_Bounded_String("A Valid String"), + "", + Map_To_Lower_Case_Ptr); + Report.Failed("Pattern_Error not raised by Function Count using " & + "a Character_Mapping_Function parameter when " & + "given a null pattern string"); + exception + when Pattern_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by Function Count " & + "using a Character_Mapping_Function parameter " & + "when given a null pattern string"); + end; + + + -- Function Translate. + + if BS40.Translate(BS40.To_Bounded_String("A Mixed Case String"), + Mapping => Map_To_Lower_Case_Ptr) /= + BS40.To_Bounded_String("a mixed case string") or + + BS20."/="(BS20.Translate(BS20.To_Bounded_String("ALL LOWER CASE"), + Map_To_Lower_Case_Ptr), + "all lower case") or + + BS20."/="("end with lower case", + BS20.Translate( + BS20.To_Bounded_String("end with lower case"), + Map_To_Lower_Case_Ptr)) or + + BS1.Translate(BS1.Null_Bounded_String, + Map_To_Lower_Case_Ptr) /= + BS1.Null_Bounded_String or + + BS80."/="(BS80.Translate(BS80.To_Bounded_String + ("start with lower case, end with upper case"), + Map_To_Upper_Case_Ptr), + "START WITH LOWER CASE, END WITH UPPER CASE") or + + BS40.Translate(BS40.To_Bounded_String("ALL UPPER CASE STRING"), + Map_To_Upper_Case_Ptr) /= + BS40.To_Bounded_String("ALL UPPER CASE STRING") or + + BS80."/="(BS80.Translate(BS80.To_Bounded_String + ("LoTs Of MiXeD CaSe ChArAcTeRs In ThE StRiNg"), + Map_To_Upper_Case_Ptr), + "LOTS OF MIXED CASE CHARACTERS IN THE STRING") + + then + Report.Failed("Incorrect results from Function Translate, using " & + "a Character_Mapping_Function parameter"); + end if; + + + -- Procedure Translate. + + BString_1 := BS1.To_Bounded_String("A"); + + BS1.Translate(Source => BString_1, Mapping => Map_To_Lower_Case_Ptr); + + if not BS1."="(BString_1, "a") then -- "=" for Bounded_String, String + Report.Failed("Incorrect result from Procedure Translate - 1"); + end if; + + BString_20 := BS20.To_Bounded_String(String_20); + BS20.Translate(BString_20, Mapping => Map_To_Lower_Case_Ptr); + + if BString_20 /= BS20.To_Bounded_String("abcdefghijklmnopqrst") then + Report.Failed("Incorrect result from Procedure Translate - 2"); + end if; + + BString_40 := BS40.To_Bounded_String("String needing highlighting"); + BS40.Translate(BString_40, Map_To_Upper_Case_Ptr); + + if not (BString_40 = "STRING NEEDING HIGHLIGHTING") then + Report.Failed("Incorrect result from Procedure Translate - 3"); + end if; + + BString_80 := BS80.Null_Bounded_String; + BS80.Translate(BString_80, Map_To_Upper_Case_Ptr); + + if not (BString_80 = BS80.Null_Bounded_String) then + Report.Failed("Incorrect result from Procedure Translate - 4"); + end if; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + +end CXA4027; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4028.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4028.a new file mode 100644 index 000000000..bc6cac14c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4028.a @@ -0,0 +1,331 @@ +-- CXA4028.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 Ada.Strings.Bounded procedures Append, Head, Tail, and +-- Trim, and relational operator functions "=", ">", ">=", "<", "<=" +-- with parameter combinations of type String and Bounded_String, +-- produce correct results. +-- +-- TEST DESCRIPTION: +-- This test examines the operation of several subprograms from within +-- the Ada.Strings.Bounded package. Four different instantiations of +-- Ada.Strings.Bounded.Generic_Bounded_Length provide packages defined +-- to manipulate bounded strings of lengths 1, 20, 40, and 80. +-- Examples of the above mentioned procedures and relational operators +-- from each of these instantiations are tested, with results compared +-- against expected output. +-- +-- Testing of the function versions of many of the subprograms tested +-- here is performed in tests CXA4006-CXA4009. +-- +-- +-- CHANGE HISTORY: +-- 16 Feb 95 SAIC Initial prerelease version +-- 10 Mar 95 SAIC Incorporated reviewer comments. +-- 15 Apr 96 SAIC Incorporated reviewer comments for ACVC 2.1. +-- +--! + +with Ada.Exceptions; +with Ada.Strings.Bounded; +with Report; + +procedure CXA4028 is + +begin + + Report.Test ("CXA4028", "Check that Ada.Strings.Bounded procedures " & + "Append, Head, Tail, and Trim, and relational " & + "operator functions =, >, >=, <, <= with " & + "parameter combinations of type String and " & + "Bounded_String, produce correct results"); + + Test_Block: + declare + + use Ada.Exceptions; + use Ada.Strings; + + -- Instantiations of Bounded String generic package. + + package BS1 is new Ada.Strings.Bounded.Generic_Bounded_Length(1); + package BS20 is new Ada.Strings.Bounded.Generic_Bounded_Length(20); + package BS40 is new Ada.Strings.Bounded.Generic_Bounded_Length(40); + package BS80 is new Ada.Strings.Bounded.Generic_Bounded_Length(80); + + use type BS1.Bounded_String, BS20.Bounded_String, + BS40.Bounded_String, BS80.Bounded_String; + + String_1 : String(1..1) := "A"; + String_20 : String(1..20) := "ABCDEFGHIJKLMNOPQRST"; + String_40 : String(1..40) := "abcdefghijklmnopqrst" & String_20; + String_80 : String(1..80) := String_40 & String_40; + + BString_1 : BS1.Bounded_String := BS1.Null_Bounded_String; + BString_20 : BS20.Bounded_String := BS20.Null_Bounded_String; + BString_40 : BS40.Bounded_String := BS40.Null_Bounded_String; + BString_80 : BS80.Bounded_String := BS80.Null_Bounded_String; + + begin + + -- Procedure Append. + + declare + use BS1, BS20; + begin + Append(Source => BString_1, New_Item => To_Bounded_String("A")); + Append(BString_1, "B", Ada.Strings.Left); + Append(BString_1, 'C', Drop => Ada.Strings.Right); -- Drop appended + -- character. + if BString_1 /= To_Bounded_String("B") then + Report.Failed("Incorrect results from BS1 versions of " & + "procedure Append"); + end if; + + Append(BString_20, 'T'); -- Character. + Append(BString_20, "his string"); -- String. + Append(BString_20, + To_Bounded_String(" is complete."), -- Bounded string. + Drop => Ada.Strings.Right); -- Drop 4 characters. + + if BString_20 /= To_Bounded_String("This string is compl") then + Report.Failed("Incorrect results from BS20 versions of " & + "procedure Append"); + end if; + end; + + + -- Operator "=". + + BString_40 := BS40.To_Bounded_String(String_40); + BString_80 := BS80.To_Bounded_String( + BS40.To_String(BString_40) & + BS40.To_String(BString_40)); + + if not (BString_40 = String_40 and -- (Bounded_String, String) + BS80."="(String_80, BString_80)) -- (String, Bounded_String) + then + Report.Failed("Incorrect results from function ""="" with " & + "string - bounded string parameter combinations"); + end if; + + + -- Operator "<". + + BString_1 := BS1.To_Bounded_String("cat", -- string "c" only. + Drop => Ada.Strings.Right); + BString_20 := BS20.To_Bounded_String("Santa Claus"); + + if BString_1 < "C" or -- (Bounded_String, String) + BS1."<"(BString_1,"c") or -- (Bounded_String, String) + "x" < BString_1 or -- (String, Bounded_String) + BString_20 < "Santa " or -- (Bounded_String, String) + "Santa and his Elves" < BString_20 -- (String, Bounded_String) + then + Report.Failed("Incorrect results from function ""<"" with " & + "string - bounded string parameter combinations"); + end if; + + + -- Operator "<=". + + BString_20 := BS20.To_Bounded_String("Sample string"); + + if BString_20 <= "Sample strin" or -- (Bounded_String, String) + "sample string" <= BString_20 or -- (String, Bounded_String) + not("Sample string" <= BString_20) -- (String, Bounded_String) + then + Report.Failed("Incorrect results from function ""<="" with " & + "string - bounded string parameter combinations"); + end if; + + + -- Operator ">". + + BString_40 := BS40.To_Bounded_String("A MUCH LONGER SAMPLE STRING."); + + if BString_40 > "A much longer sample string" or -- (Bnd_Str, Str) + String_20 > BS40.To_Bounded_String(String_40) or -- (Str, Bnd_Str) + BS40.To_Bounded_String("ABCDEFGH") > "abcdefgh" -- (Str, Bnd_Str) + then + Report.Failed("Incorrect results from function "">"" with " & + "string - bounded string parameter combinations"); + end if; + + + -- Operator ">=". + + BString_80 := BS80.To_Bounded_String(String_80); + + if not (BString_80 >= String_80 and + BS80.To_Bounded_String("Programming") >= "PROGRAMMING" and + "test" >= BS80.To_Bounded_String("tess")) + then + Report.Failed("Incorrect results from function "">="" with " & + "string - bounded string parameter combinations"); + end if; + + + -- Procedure Trim + + BString_20 := BS20.To_Bounded_String(" Left Spaces "); + BS20.Trim(Source => BString_20, + Side => Ada.Strings.Left); + + if "Left Spaces " /= BString_20 then + Report.Failed("Incorrect results from Procedure Trim with " & + "Side = Left"); + end if; + + BString_40 := BS40.To_Bounded_String(" Right Spaces "); + BS40.Trim(BString_40, Side => Ada.Strings.Right); + + if BString_40 /= " Right Spaces" then + Report.Failed("Incorrect results from Procedure Trim with " & + "Side = Right"); + end if; + + BString_20 := BS20.To_Bounded_String(" Both Sides "); + BS20.Trim(BString_20, Ada.Strings.Both); + + if BString_20 /= BS20.To_Bounded_String("Both Sides") then + Report.Failed("Incorrect results from Procedure Trim with " & + "Side = Both"); + end if; + + BString_80 := BS80.To_Bounded_String("Centered Spaces"); + BS80.Trim(BString_80, Ada.Strings.Both); + + if BString_80 /= BS80.To_Bounded_String("Centered Spaces") then + Report.Failed("Incorrect results from Procedure Trim with " & + "no blank spaces on the ends of the string"); + end if; + + + -- Procedure Head + + BString_40 := BS40.To_Bounded_String("Test String"); + BS40.Head(Source => BString_40, + Count => 4); -- Count < Source'Length + + if BString_40 /= BS40.To_Bounded_String("Test") then + Report.Failed("Incorrect results from Procedure Head with " & + "the Count parameter less than Source'Length"); + end if; + + BString_1 := BS1.To_Bounded_String("X"); + BS1.Head(BString_1, BS1.Length(BString_1)); -- Count = Source'Length + + if BString_1 /= "X" then + Report.Failed("Incorrect results from Procedure Head with " & + "the Count parameter equal to Source'Length"); + end if; + + BString_20 := BS20.To_Bounded_String("Sample string"); + BS20.Head(BString_20, + Count => BS20.Max_Length, -- Count > Source'Length + Pad => '*'); + + if BString_20 /= BS20.To_Bounded_String("Sample string*******") then + Report.Failed("Incorrect results from Procedure Head with " & + "the Count parameter greater than Source'Length"); + end if; + + BString_20 := BS20.To_Bounded_String("Twenty Characters 20"); + BS20.Head(BString_20, 22, Pad => '*', Drop => Ada.Strings.Left); + + if BString_20 /= "enty Characters 20**" then + Report.Failed("Incorrect results from Procedure Head with " & + "the Count parameter greater than Source'Length, " & + "and the Drop parameter = Left"); + end if; + + BString_20 := BS20.To_Bounded_String("Short String"); + BS20.Head(BString_20, 23, '-', Ada.Strings.Right); + + if ("Short String--------") /= BString_20 then + Report.Failed("Incorrect results from Procedure Head with " & + "the Count parameter greater than Source'Length, " & + "and the Drop parameter = Right"); + end if; + + + -- Procedure Tail + + BString_40 := BS40.To_Bounded_String("Test String"); + BS40.Tail(Source => BString_40, + Count => 6); -- Count < Source'Length + + if BString_40 /= BS40.To_Bounded_String("String") then + Report.Failed("Incorrect results from Procedure Tail with " & + "the Count parameter less than Source'Length"); + end if; + + BString_1 := BS1.To_Bounded_String("X"); + BS1.Tail(BString_1, BS1.Length(BString_1)); -- Count = Source'Length + + if BString_1 /= "X" then + Report.Failed("Incorrect results from Procedure Tail with " & + "the Count parameter equal to Source'Length"); + end if; + + BString_20 := BS20.To_Bounded_String("Sample string"); + BS20.Tail(BString_20, + Count => BS20.Max_Length, -- Count > Source'Length + Pad => '*'); + + if BString_20 /= BS20.To_Bounded_String("*******Sample string") then + Report.Failed("Incorrect results from Procedure Tail with " & + "the Count parameter greater than Source'Length"); + end if; + + BString_20 := BS20.To_Bounded_String("Twenty Characters"); -- Len = 17 + BS20.Tail(BString_20, 22, Pad => '*', Drop => Ada.Strings.Left); + + if BString_20 /= "***Twenty Characters" then + Report.Failed("Incorrect results from Procedure Tail with " & + "the Count parameter greater than Source'Length, " & + "and the Drop parameter = Left"); + end if; + + BString_20 := BS20.To_Bounded_String("Maximum Length Chars"); + BS20.Tail(BString_20, 23, '-', Ada.Strings.Right); + + if ("---Maximum Length Ch") /= BString_20 then + Report.Failed("Incorrect results from Procedure Tail with " & + "the Count parameter greater than Source'Length, " & + "and the Drop parameter = Right"); + 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 CXA4028; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4029.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4029.a new file mode 100644 index 000000000..714067454 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4029.a @@ -0,0 +1,333 @@ +-- CXA4029.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 functionality found in packages Ada.Strings.Wide_Maps, +-- Ada.Strings.Wide_Bounded, and Ada.Strings.Wide_Maps.Wide_Constants +-- is available and produces correct results. +-- +-- TEST DESCRIPTION: +-- This test tests the subprograms found in the +-- Ada.Strings.Wide_Bounded package. It is based on the tests +-- CXA4027-28, which are tests for the complementary "non-wide" +-- packages. +-- +-- The functions found in CXA4029_0 provide mapping capability, when +-- used in conjunction with Wide_Character_Mapping_Function objects. +-- +-- +-- CHANGE HISTORY: +-- 23 Jun 95 SAIC Initial prerelease version. +-- 18 Apr 96 SAIC Incorporated reviewer comments for ACVC 2.1. +-- +--! + +package CXA4029_0 is + -- Functions used to supply mapping capability. + function Map_To_Lower_Case (From : Wide_Character) return Wide_Character; + function Map_To_Upper_Case (From : Wide_Character) return Wide_Character; +end CXA4029_0; + +with Ada.Characters.Handling; +package body CXA4029_0 is + -- Function Map_To_Lower_Case will return the lower case form of + -- Wide_Characters in the range 'A'..'Z' only, and return the input + -- wide_character otherwise. + + function Map_To_Lower_Case (From : Wide_Character) + return Wide_Character is + begin + return Ada.Characters.Handling.To_Wide_Character( + Ada.Characters.Handling.To_Lower( + Ada.Characters.Handling.To_Character(From))); + end Map_To_Lower_Case; + + -- Function Map_To_Upper_Case will return the upper case form of + -- Wide_Characters in the range 'a'..'z', or whose position is in one + -- of the ranges 223..246 or 248..255, provided the wide_character has + -- an upper case form. + + function Map_To_Upper_Case (From : Wide_Character) + return Wide_Character is + begin + return Ada.Characters.Handling.To_Wide_Character( + Ada.Characters.Handling.To_Upper( + Ada.Characters.Handling.To_Character(From))); + end Map_To_Upper_Case; + +end CXA4029_0; + + +with CXA4029_0; +with Report; +with Ada.Characters.Handling; +with Ada.Characters.Latin_1; +with Ada.Strings; +with Ada.Strings.Wide_Maps; +with Ada.Strings.Wide_Maps.Wide_Constants; +with Ada.Strings.Wide_Fixed; +with Ada.Strings.Wide_Bounded; + +procedure CXA4029 is +begin + Report.Test ("CXA4029", + "Check that subprograms defined in package " & + "Ada.Strings.Wide_Bounded produce correct results"); + + Test_Block: + declare + + package ACL1 renames Ada.Characters.Latin_1; + package BS1 is new Ada.Strings.Wide_Bounded.Generic_Bounded_Length(1); + package BS20 is new Ada.Strings.Wide_Bounded.Generic_Bounded_Length(20); + package BS40 is new Ada.Strings.Wide_Bounded.Generic_Bounded_Length(40); + package BS80 is new Ada.Strings.Wide_Bounded.Generic_Bounded_Length(80); + + subtype LC_Characters is Wide_Character range 'a'..'z'; + + use Ada.Characters, Ada.Strings; + use type Wide_Maps.Wide_Character_Set; + use type BS1.Bounded_Wide_String, BS20.Bounded_Wide_String, + BS40.Bounded_Wide_String, BS80.Bounded_Wide_String; + + TC_String : constant Wide_String := "A Standard String"; + + BString_1 : BS1.Bounded_Wide_String := + BS1.Null_Bounded_Wide_String; + BString_20 : BS20.Bounded_Wide_String := + BS20.Null_Bounded_Wide_String; + BString_40 : BS40.Bounded_Wide_String := + BS40.Null_Bounded_Wide_String; + BString_80 : BS80.Bounded_Wide_String := + BS80.Null_Bounded_Wide_String; + String_20 : Wide_String(1..20) := "ABCDEFGHIJKLMNOPQRST"; + String_40 : Wide_String(1..40) := "abcdefghijklmnopqrst" & + String_20; + String_80 : Wide_String(1..80) := String_40 & String_40; + TC_String_5 : Wide_String(1..5) := "ABCDE"; + + -- The following strings are used in examination of the Translation + -- subprograms. + New_Character_String : Wide_String(1..10) := + Handling.To_Wide_String( + ACL1.LC_A_Grave & ACL1.LC_A_Ring & ACL1.LC_AE_Diphthong & + ACL1.LC_C_Cedilla & ACL1.LC_E_Acute & ACL1.LC_I_Circumflex & + ACL1.LC_Icelandic_Eth & ACL1.LC_N_Tilde & + ACL1.LC_O_Oblique_Stroke & ACL1.LC_Icelandic_Thorn); + + TC_New_Character_String : Wide_String(1..10) := + Handling.To_Wide_String( + ACL1.UC_A_Grave & ACL1.UC_A_Ring & ACL1.UC_AE_Diphthong & + ACL1.UC_C_Cedilla & ACL1.UC_E_Acute & ACL1.UC_I_Circumflex & + ACL1.UC_Icelandic_Eth & ACL1.UC_N_Tilde & + ACL1.UC_O_Oblique_Stroke & ACL1.UC_Icelandic_Thorn); + + -- Access objects that will be provided as parameters to the + -- subprograms. + Map_To_Lower_Case_Ptr : Wide_Maps.Wide_Character_Mapping_Function := + CXA4029_0.Map_To_Lower_Case'Access; + Map_To_Upper_Case_Ptr : Wide_Maps.Wide_Character_Mapping_Function := + CXA4029_0.Map_To_Upper_Case'Access; + + begin + + -- Testing of functionality found in Package Ada.Strings.Wide_Bounded. + -- + -- Function Index. + + if BS80.Index(BS80.To_Bounded_Wide_String("CoMpLeTeLy MiXeD CaSe"), + "MIXED CASE", + Ada.Strings.Forward, + Map_To_Upper_Case_Ptr) /= 12 or + BS1.Index(BS1.Null_Bounded_Wide_String, + "i", + Mapping => Map_To_Lower_Case_Ptr) /= 0 + then + Report.Failed("Incorrect results from BND Function Index, going " & + "in Forward direction, using a Character Mapping " & + "Function parameter"); + end if; + + -- Function Count. + if BS40.Count(BS40.To_Bounded_Wide_String("This IS a MISmatched issue"), + "is", + Map_To_Lower_Case_Ptr) /= 4 or + BS80.Count(BS80.To_Bounded_Wide_String("ABABABA"), + "ABA", + Map_To_Upper_Case_Ptr) /= 2 + then + Report.Failed("Incorrect results from BND Function Count, using " & + "a Character_Mapping_Function parameter"); + end if; + + -- Function Translate. + if BS40.Translate(BS40.To_Bounded_Wide_String("A Mixed Case String"), + Mapping => Map_To_Lower_Case_Ptr) /= + BS40.To_Bounded_Wide_String("a mixed case string") or + BS20."/="("end with lower case", + BS20.Translate( + BS20.To_Bounded_Wide_String("end with lower case"), + Map_To_Lower_Case_Ptr)) + then + Report.Failed("Incorrect results from BND Function Translate, " & + "using a Character_Mapping_Function parameter"); + end if; + + -- Procedure Translate. + BString_20 := BS20.To_Bounded_Wide_String(String_20); + BS20.Translate(BString_20, Mapping => Map_To_Lower_Case_Ptr); + if BString_20 /= BS20.To_Bounded_Wide_String("abcdefghijklmnopqrst") + then + Report.Failed("Incorrect result from BND Procedure Translate - 1"); + end if; + + BString_80 := BS80.Null_Bounded_Wide_String; + BS80.Translate(BString_80, Map_To_Upper_Case_Ptr); + if not (BString_80 = BS80.Null_Bounded_Wide_String) then + Report.Failed("Incorrect result from BND Procedure Translate - 2"); + end if; + + -- Procedure Append. + declare + use BS20; + begin + BString_20 := BS20.Null_Bounded_Wide_String; + Append(BString_20, 'T'); + Append(BString_20, "his string"); + Append(BString_20, + To_Bounded_Wide_String(" is complete."), + Drop => Ada.Strings.Right); -- Drop 4 characters. + if BString_20 /= To_Bounded_Wide_String("This string is compl") then + Report.Failed("Incorrect results from BS20 versions of " & + "procedure Append"); + end if; + exception + when others => Report.Failed("Exception raised in block checking " & + "BND Procedure Append"); + end; + + -- Operator "=". + BString_40 := BS40.To_Bounded_Wide_String(String_40); + BString_80 := BS80.To_Bounded_Wide_String( + BS40.To_Wide_String(BString_40) & + BS40.To_Wide_String(BString_40)); + if not (BString_40 = String_40 and + BS80."="(String_80, BString_80)) then + Report.Failed("Incorrect results from BND Function ""="" with " & + "string - bounded string parameter combinations"); + end if; + + -- Operator "<". + BString_1 := BS1.To_Bounded_Wide_String("cat", + Drop => Ada.Strings.Right); + BString_20 := BS20.To_Bounded_Wide_String("Santa Claus"); + if BString_1 < "C" or + BS1."<"(BString_1,"c") or + BS1."<"("x", BString_1) or + BS20."<"(BString_20,"Santa ") or + BS20."<"("Santa and his Elves", BString_20) + then + Report.Failed("Incorrect results from BND Function ""<"" with " & + "string - bounded string parameter combinations"); + end if; + + -- Operator "<=". + BString_20 := BS20.To_Bounded_Wide_String("Sample string"); + if BS20."<="(BString_20,"Sample strin") or + not(BS20."<="("Sample string",BString_20)) + then + Report.Failed("Incorrect results from BND Function ""<="" with " & + "string - bounded string parameter combinations"); + end if; + + -- Operator ">". + BString_40 := BS40.To_Bounded_Wide_String( + "A MUCH LONGER SAMPLE STRING."); + if BString_40 > "A much longer sample string" or + BS40.To_Bounded_Wide_String("ABCDEFGH") > "abcdefgh" + then + Report.Failed("Incorrect results from BND Function "">"" with " & + "string - bounded string parameter combinations"); + end if; + + -- Operator ">=". + BString_80 := BS80.To_Bounded_Wide_String(String_80); + if not (BString_80 >= String_80 and + BS80.To_Bounded_Wide_String("Programming") >= "PROGRAMMING" and + BS80.">="("test", BS80.To_Bounded_Wide_String("tess"))) + then + Report.Failed("Incorrect results from BND Function "">="" with " & + "string - bounded string parameter combinations"); + end if; + + -- Procedure Trim + BString_20 := BS20.To_Bounded_Wide_String(" Both Sides "); + BS20.Trim(BString_20, Ada.Strings.Both); + if BString_20 /= BS20.To_Bounded_Wide_String("Both Sides") then + Report.Failed("Incorrect results from BND Procedure Trim with " & + "Side = Both"); + end if; + + -- Procedure Head + BString_40 := BS40.To_Bounded_Wide_String("Test String"); + BS40.Head(Source => BString_40, + Count => 4); -- Count < Source'Length + if BString_40 /= BS40.To_Bounded_Wide_String("Test") then + Report.Failed("Incorrect results from BND Procedure Head with " & + "the Count parameter less than Source'Length"); + end if; + + BString_20 := BS20.To_Bounded_Wide_String("Short String"); + BS20.Head(BString_20, 23, '-', Ada.Strings.Right); + if BS20.To_Bounded_Wide_String("Short String--------") /= BString_20 then + Report.Failed("Incorrect results from BND Procedure Head with " & + "the Count parameter greater than Source'Length, " & + "and the Drop parameter = Right"); + end if; + + -- Procedure Tail + BString_40 := BS40.To_Bounded_Wide_String("Test String"); + BS40.Tail(Source => BString_40, + Count => 6); + if BString_40 /= BS40.To_Bounded_Wide_String("String") then + Report.Failed("Incorrect results from BND Procedure Tail with " & + "the Count parameter less than Source'Length"); + end if; + + BString_20 := BS20.To_Bounded_Wide_String("Maximum Length Chars"); + BS20.Tail(BString_20, 23, '-', Ada.Strings.Right); + if BS20.To_Bounded_Wide_String("---Maximum Length Ch") /= BString_20 then + Report.Failed("Incorrect results from BND Procedure Tail with " & + "the Count parameter greater than Source'Length, " & + "and the Drop parameter = Right"); + end if; + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + +end CXA4029; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4030.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4030.a new file mode 100644 index 000000000..475d00899 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4030.a @@ -0,0 +1,414 @@ +-- CXA4030.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 Ada.Strings.Unbounded versions of subprograms Translate +-- (procedure and function), Index, and Count, which use a +-- Maps.Character_Mapping_Function input parameter, produce correct +-- results. +-- +-- TEST DESCRIPTION: +-- This test examines the operation of the four subprograms contained +-- in the Ada.Strings.Unbounded package that use a +-- Character_Mapping_Function parameter to provide the mapping +-- capability. +-- Two Character_Mapping_Function objects are defined that reference +-- subprograms contained in the Ada.Characters.Handling package; +-- To_Lower will return the lower-case form of the character provided +-- as the input parameter, To_Upper will return the upper-case form +-- of the character input parameter (provided there is an upper-case +-- form). +-- In several instances in this test, the character handling functions +-- are referenced directly in the parameter list of the subprograms +-- under test, demonstrating another form of expected common usage. +-- +-- Results of all subprograms are compared with expected results. +-- +-- This test, when taken in conjunction with tests CXA4010, CXA4011, +-- CXA4031, and CXA4032 will constitute a test of all the functionality +-- contained in package Ada.Strings.Unbounded. This test uses a variety +-- of the subprograms defined in the unbounded string package in ways +-- typical of common usage. +-- +-- +-- CHANGE HISTORY: +-- 21 Feb 95 SAIC Initial prerelease version +-- 21 Apr 95 SAIC Modified header commentary. +-- +--! + +with Ada.Strings.Unbounded; +with Ada.Strings.Maps; +with Ada.Characters.Handling; +with Ada.Characters.Latin_1; +with Report; + +procedure CXA4030 is + +begin + + Report.Test ("CXA4030", "Check that Ada.Strings.Unbounded versions " & + "of subprograms Translate (procedure and " & + "function), Index, and Count, which use a " & + "Maps.Character_Mapping_Function input " & + "parameter, produce correct results"); + + Test_Block: + declare + + package Unb renames Ada.Strings.Unbounded; + use type Unb.Unbounded_String; + use Ada.Strings; + use Ada.Characters; + + + -- The following strings are used in examination of the Translation + -- subprograms. + + New_Character_String : Unb.Unbounded_String := + Unb.To_Unbounded_String( + Latin_1.LC_A_Grave & + Latin_1.LC_A_Ring & + Latin_1.LC_AE_Diphthong & + Latin_1.LC_C_Cedilla & + Latin_1.LC_E_Acute & + Latin_1.LC_I_Circumflex & + Latin_1.LC_Icelandic_Eth & + Latin_1.LC_N_Tilde & + Latin_1.LC_O_Oblique_Stroke & + Latin_1.LC_Icelandic_Thorn); + + + TC_New_Character_String : Unb.Unbounded_String := + Unb.To_Unbounded_String( + Latin_1.UC_A_Grave & + Latin_1.UC_A_Ring & + Latin_1.UC_AE_Diphthong & + Latin_1.UC_C_Cedilla & + Latin_1.UC_E_Acute & + Latin_1.UC_I_Circumflex & + Latin_1.UC_Icelandic_Eth & + Latin_1.UC_N_Tilde & + Latin_1.UC_O_Oblique_Stroke & + Latin_1.UC_Icelandic_Thorn); + + + -- In this test, access objects are defined to refer to two functions + -- from the Ada.Characters.Handling package. These access objects + -- will be provided as parameters to the subprograms under test. + -- Note: There will be several examples in this test of these character + -- handling functions being referenced directly within the + -- parameter list of the subprograms under test. + + Map_To_Lower_Case_Ptr : Maps.Character_Mapping_Function := + Handling.To_Lower'Access; + + Map_To_Upper_Case_Ptr : Maps.Character_Mapping_Function := + Handling.To_Upper'Access; + + begin + + -- Function Index, Forward direction search. + -- Note: Several of the following cases use the default value + -- Forward for the Going parameter. + + if Unb.Index(Source => Unb.To_Unbounded_String( + "The library package Strings.Unbounded"), + Pattern => "unb", + Going => Ada.Strings.Forward, + Mapping => Map_To_Lower_Case_Ptr) /= 29 or + + Unb.Index(Unb.To_Unbounded_String( + "THE RAIN IN SPAIN FALLS MAINLY ON THE PLAIN"), + "ain", + Mapping => Map_To_Lower_Case_Ptr) /= 6 or + + Unb.Index(Unb.To_Unbounded_String("maximum number"), + "um", + Ada.Strings.Forward, + Handling.To_Lower'Access) /= 6 or + + Unb.Index(Unb.To_Unbounded_String("CoMpLeTeLy MiXeD CaSe StRiNg"), + "MIXED CASE STRING", + Ada.Strings.Forward, + Map_To_Upper_Case_Ptr) /= 12 or + + Unb.Index(Unb.To_Unbounded_String( + "STRING WITH NO MATCHING PATTERNS"), + "WITH", + Mapping => Map_To_Lower_Case_Ptr) /= 0 or + + Unb.Index(Unb.To_Unbounded_String("THIS STRING IS IN UPPER CASE"), + "IS", + Ada.Strings.Forward, + Handling.To_Upper'Access) /= 3 or + + Unb.Index(Unb.Null_Unbounded_String, + "is", + Mapping => Map_To_Lower_Case_Ptr) /= 0 or + + Unb.Index(Unb.To_Unbounded_String("AAABBBaaabbb"), + "aabb", + Mapping => Handling.To_Lower'Access) /= 2 + then + Report.Failed("Incorrect results from Function Index, going " & + "in Forward direction, using a Character Mapping " & + "Function parameter"); + end if; + + + + -- Function Index, Backward direction search. + + if Unb.Index(Unb.To_Unbounded_String("Case of a Mixed Case String"), + "case", + Ada.Strings.Backward, + Map_To_Lower_Case_Ptr) /= 17 or + + Unb.Index(Unb.To_Unbounded_String("Case of a Mixed Case String"), + "CASE", + Ada.Strings.Backward, + Mapping => Map_To_Upper_Case_Ptr) /= 17 or + + Unb.Index(Unb.To_Unbounded_String("rain, Rain, and more RAIN"), + "rain", + Ada.Strings.Backward, + Handling.To_Lower'Access) /= 22 or + + Unb.Index(Unb.To_Unbounded_String("RIGHT place, right time"), + "RIGHT", + Ada.Strings.Backward, + Handling.To_Upper'Access) /= 14 or + + Unb.Index(Unb.To_Unbounded_String("WOULD MATCH BUT FOR THE CASE"), + "WOULD MATCH BUT FOR THE CASE", + Going => Ada.Strings.Backward, + Mapping => Map_To_Lower_Case_Ptr) /= 0 + then + Report.Failed("Incorrect results from Function Index, going " & + "in Backward direction, using a Character Mapping " & + "Function parameter"); + end if; + + + + -- Function Index, Pattern_Error if Pattern = Null_String + + declare + use Unbounded; + Null_String : constant String := ""; + TC_Natural : Natural := 1000; + begin + TC_Natural := Index(To_Unbounded_String("A Valid Unbounded String"), + Null_String, + Going => Ada.Strings.Forward, + Mapping => Handling.To_Lower'Access); + Report.Failed("Pattern_Error not raised by Function Index when " & + "given a null pattern string"); + exception + when Pattern_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by Function Index " & + "using a Character Mapping Function parameter " & + "when given a null pattern string"); + end; + + + + -- Function Count. + + if Unb.Count(Source => Unb.To_Unbounded_String("ABABABA"), + Pattern => "aba", + Mapping => Map_To_Lower_Case_Ptr) /= 2 or + + Unb.Count(Unb.To_Unbounded_String("ABABABA"), + "ABA", + Mapping => Map_To_Lower_Case_Ptr) /= 0 or + + Unb.Count(Unb.To_Unbounded_String("This IS a MISmatched issue"), + "is", + Handling.To_Lower'Access) /= 4 or + + Unb.Count(Unb.To_Unbounded_String("ABABABA"), + "ABA", + Map_To_Upper_Case_Ptr) /= 2 or + + Unb.Count(Unb.To_Unbounded_String("This IS a MISmatched issue"), + "is", + Mapping => Map_To_Upper_Case_Ptr) /= 0 or + + Unb.Count(Unb.To_Unbounded_String( + "She sells sea shells by the sea shore"), + "s", + Handling.To_Lower'Access) /= 8 or + + Unb.Count(Unb.Null_Unbounded_String, + "match", + Map_To_Upper_Case_Ptr) /= 0 + then + Report.Failed("Incorrect results from Function Count, using " & + "a Character Mapping Function parameter"); + end if; + + + + -- Function Count, Pattern_Error if Pattern = Null_String + + declare + use Ada.Strings.Unbounded; + Null_Pattern_String : constant String := ""; + TC_Natural : Natural := 1000; + begin + TC_Natural := Count(To_Unbounded_String("A Valid String"), + Null_Pattern_String, + Map_To_Lower_Case_Ptr); + Report.Failed("Pattern_Error not raised by Function Count using " & + "a Character Mapping Function parameter when " & + "given a null pattern string"); + exception + when Pattern_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by Function Count " & + "using a Character Mapping Function parameter " & + "when given a null pattern string"); + end; + + + + -- Function Translate. + + if Unb.Translate(Source => Unb.To_Unbounded_String( + "A Sample Mixed Case String"), + Mapping => Map_To_Lower_Case_Ptr) /= + Unb.To_Unbounded_String("a sample mixed case string") or + + Unb.Translate(Unb.To_Unbounded_String("ALL LOWER CASE"), + Handling.To_Lower'Access) /= + Unb.To_Unbounded_String("all lower case") or + + Unb.Translate(Unb.To_Unbounded_String("end with lower case"), + Map_To_Lower_Case_Ptr) /= + Unb.To_Unbounded_String("end with lower case") or + + Unb.Translate(Unb.Null_Unbounded_String, + Handling.To_Lower'Access) /= + Unb.Null_Unbounded_String or + + Unb.Translate(Unb.To_Unbounded_String("start with lower case"), + Map_To_Upper_Case_Ptr) /= + Unb.To_Unbounded_String("START WITH LOWER CASE") or + + Unb.Translate(Unb.To_Unbounded_String("ALL UPPER CASE STRING"), + Handling.To_Upper'Access) /= + Unb.To_Unbounded_String("ALL UPPER CASE STRING") or + + Unb.Translate(Unb.To_Unbounded_String( + "LoTs Of MiXeD CaSe ChArAcTeRs"), + Map_To_Upper_Case_Ptr) /= + Unb.To_Unbounded_String("LOTS OF MIXED CASE CHARACTERS") or + + Unb.Translate(New_Character_String, + Handling.To_Upper'Access) /= + TC_New_Character_String + + then + Report.Failed("Incorrect results from Function Translate, using " & + "a Character Mapping Function parameter"); + end if; + + + + -- Procedure Translate. + + declare + + use Ada.Strings.Unbounded; + use Ada.Characters.Handling; + + Str_1 : Unbounded_String := + To_Unbounded_String("AN ALL UPPER CASE STRING"); + Str_2 : Unbounded_String := + To_Unbounded_String("A Mixed Case String"); + Str_3 : Unbounded_String := + To_Unbounded_String("a string with lower case letters"); + TC_Str_1 : constant Unbounded_String := Str_1; + TC_Str_3 : constant Unbounded_String := Str_3; + + begin + + Translate(Source => Str_1, Mapping => Map_To_Lower_Case_Ptr); + + if Str_1 /= To_Unbounded_String("an all upper case string") then + Report.Failed("Incorrect result from Procedure Translate - 1"); + end if; + + Translate(Source => Str_1, Mapping => Map_To_Upper_Case_Ptr); + + if Str_1 /= TC_Str_1 then + Report.Failed("Incorrect result from Procedure Translate - 2"); + end if; + + Translate(Str_2, Mapping => Map_To_Lower_Case_Ptr); + + if Str_2 /= To_Unbounded_String("a mixed case string") then + Report.Failed("Incorrect result from Procedure Translate - 3"); + end if; + + Translate(Str_2, Mapping => To_Upper'Access); + + if Str_2 /= To_Unbounded_String("A MIXED CASE STRING") then + Report.Failed("Incorrect result from Procedure Translate - 4"); + end if; + + Translate(Str_3, To_Lower'Access); + + if Str_3 /= TC_Str_3 then + Report.Failed("Incorrect result from Procedure Translate - 5"); + end if; + + Translate(Str_3, To_Upper'Access); + + if Str_3 /= + To_Unbounded_String("A STRING WITH LOWER CASE LETTERS") + then + Report.Failed("Incorrect result from Procedure Translate - 6"); + end if; + + Translate(New_Character_String, Map_To_Upper_Case_Ptr); + + if New_Character_String /= TC_New_Character_String then + Report.Failed("Incorrect result from Procedure Translate - 6"); + end if; + + end; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + +end CXA4030; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4031.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4031.a new file mode 100644 index 000000000..91bc68ce6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4031.a @@ -0,0 +1,291 @@ +-- CXA4031.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 subprograms defined in package Ada.Strings.Unbounded +-- are available, and that they produce correct results. Specifically, +-- check the functions To_Unbounded_String (version with Length +-- parameter), "=", "<", "<=", ">", ">=" (all with String-Unbounded +-- String parameter mix), as well as three versions of Procedure Append. +-- +-- TEST DESCRIPTION: +-- This test demonstrates the uses of many of the subprograms defined +-- in package Ada.Strings.Unbounded for use with unbounded strings. +-- The test simulates how unbounded strings could be processed in a +-- user environment, using the subprograms provided in this package. +-- +-- This test, when taken in conjunction with tests CXA4010, CXA4011, +-- CXA4030, and CXA4032 will constitute a test of all the functionality +-- contained in package Ada.Strings.Unbounded. This test uses a variety +-- of the subprograms defined in the unbounded string package in ways +-- typical of common usage. +-- +-- +-- CHANGE HISTORY: +-- 27 Feb 95 SAIC Initial prerelease version. +-- 18 Apr 96 SAIC Incorporated reviewer comments for ACVC 2.1. +-- +--! + +with Report; +with Ada.Exceptions; +with Ada.Strings.Maps; +with Ada.Strings.Unbounded; + +procedure CXA4031 is +begin + + Report.Test ("CXA4031", "Check that the subprograms defined in " & + "package Ada.Strings.Unbounded are available, " & + "and that they produce correct results"); + + Test_Block: + declare + + package Unb renames Ada.Strings.Unbounded; + use Unb; + use Ada.Exceptions; + + subtype LC_Characters is Character range 'a'..'z'; + + Null_String : constant String := ""; + TC_String : constant String := "A Standard String"; + + TC_Unb_String, + TC_New_Unb_String : Unb.Unbounded_String := Unb.Null_Unbounded_String; + + begin + + -- Function To_Unbounded_String (version with Length parameter) + -- returns an unbounded string that represents an uninitialized String + -- whose length is Length. + -- Note: Unbounded_String length can vary conceptually between 0 and + -- Natural'Last. + + if Unb.Length(Unb.To_Unbounded_String(Length => 10)) /= 10 or + Unb.Length(Unb.To_Unbounded_String(1)) /= 1 or + Unb.Length(Unb.To_Unbounded_String(0)) /= 0 or + Unb.Length(Unb."&"(Unb.To_Unbounded_String(Length => 10), + Unb."&"(Unb.To_Unbounded_String(1), + Unb.To_Unbounded_String(0) ))) /= 10+1+0 + then + Report.Failed + ("Incorrect results from Function To_Unbounded_String with " & + "Length parameter"); + end if; + + + -- Procedure Append (Unbounded - Unbounded) + -- Note: For each of the Append procedures, the resulting string + -- represented by the Source parameter is given by the + -- concatenation of the original value of Source and the value + -- of New_Item. + + TC_Unb_String := Unb.To_Unbounded_String("Sample string of length L"); + TC_New_Unb_String := Unb.To_Unbounded_String(" and then some"); + + Unb.Append(Source => TC_Unb_String, New_Item => TC_New_Unb_String); + + if TC_Unb_String /= + Unb.To_Unbounded_String("Sample string of length L and then some") + then + Report.Failed("Incorrect results from Procedure Append with " & + "unbounded string parameters - 1"); + end if; + + + TC_Unb_String := Unb.To_Unbounded_String("Sample string of length L"); + TC_New_Unb_String := Unb.Null_Unbounded_String; + + Unb.Append(TC_Unb_String, TC_New_Unb_String); + + if TC_Unb_String /= + Unb.To_Unbounded_String("Sample string of length L") + then + Report.Failed("Incorrect results from Procedure Append with " & + "unbounded string parameters - 2"); + end if; + + + TC_Unb_String := Unb.Null_Unbounded_String; + + Unb.Append(TC_Unb_String, + Unb.To_Unbounded_String("New Unbounded String")); + + if TC_Unb_String /= + Unb.To_Unbounded_String("New Unbounded String") + then + Report.Failed("Incorrect results from Procedure Append with " & + "unbounded string parameters - 3"); + end if; + + + -- Procedure Append (Unbounded - String) + + TC_Unb_String := Unb.To_Unbounded_String("An Unbounded String and "); + + Unb.Append(Source => TC_Unb_String, New_Item => TC_String); + + if TC_Unb_String /= + Unb.To_Unbounded_String("An Unbounded String and A Standard String") + then + Report.Failed("Incorrect results from Procedure Append with " & + "an unbounded string parameter and a string " & + "parameter - 1"); + end if; + + + TC_Unb_String := Unb.To_Unbounded_String("An Unbounded String"); + + Unb.Append(TC_Unb_String, New_Item => Null_String); + + if TC_Unb_String /= + Unb.To_Unbounded_String("An Unbounded String") + then + Report.Failed("Incorrect results from Procedure Append with " & + "an unbounded string parameter and a string " & + "parameter - 2"); + end if; + + + TC_Unb_String := Unb.Null_Unbounded_String; + + Unb.Append(TC_Unb_String, TC_String); + + if TC_Unb_String /= Unb.To_Unbounded_String("A Standard String") then + Report.Failed("Incorrect results from Procedure Append with " & + "an unbounded string parameter and a string " & + "parameter - 3"); + end if; + + + -- Procedure Append (Unbounded - Character) + + TC_Unb_String := Unb.To_Unbounded_String("Lower Case = "); + + for i in LC_Characters'Range loop + Unb.Append(Source => TC_Unb_String, New_Item => LC_Characters(i)); + end loop; + + if TC_Unb_String /= + Unb.To_Unbounded_String("Lower Case = abcdefghijklmnopqrstuvwxyz") + then + Report.Failed("Incorrect results from Procedure Append with " & + "an unbounded string parameter and a character " & + "parameter - 1"); + end if; + + + TC_Unb_String := Unb.Null_Unbounded_String; + + Unb.Append(TC_Unb_String, New_Item => 'a'); + + if TC_Unb_String /= Unb.To_Unbounded_String("a") then + Report.Failed("Incorrect results from Procedure Append with " & + "an unbounded string parameter and a character " & + "parameter - 2"); + end if; + + + -- Function "=" + + TC_Unb_String := Unb.To_Unbounded_String(TC_String); + + if not (TC_Unb_String = TC_String) or -- (Unb_Str, Str) + not Unb."="("A Standard String", TC_Unb_String) or -- (Str, Unb_Str) + not ((Unb.Null_Unbounded_String = "") and -- (Unb_Str, Str) + ("Test String" = -- (Str, Unb_Str) + Unb.To_Unbounded_String("Test String"))) + then + Report.Failed("Incorrect results from function ""="" with " & + "string - unbounded string parameter combinations"); + end if; + + + -- Function "<" + + if not ("Extra Space" < Unb.To_Unbounded_String("Extra Space ") and + Unb.To_Unbounded_String("tess") < "test" and + Unb.To_Unbounded_String("best") < "test") or + Unb.Null_Unbounded_String < Null_String or + " leading blank" < Unb.To_Unbounded_String(" leading blank") or + "ending blank " < Unb.To_Unbounded_String("ending blank ") + then + Report.Failed("Incorrect results from function ""<"" with " & + "string - unbounded string parameter combinations"); + end if; + + + -- Function "<=" + + TC_Unb_String := Unb.To_Unbounded_String("Sample string"); + + if TC_Unb_String <= "Sample strin" or -- (Unb_Str, Str) + "sample string" <= TC_Unb_String or -- (Str, Unb_Str) + not(Unb.Null_Unbounded_String <= "") or -- (Unb_Str, Str) + not("Sample string" <= TC_Unb_String) -- (Str, Unb_Str) + then + Report.Failed("Incorrect results from function ""<="" with " & + "string - unbounded string parameter combinations"); + end if; + + + -- Function ">" + + TC_Unb_String := Unb.To_Unbounded_String("A MUCH LONGER STRING"); + + if not ("A much longer string" > TC_Unb_String and + Unb.To_Unbounded_String(TC_String) > "A Standard Strin" and + "abcdefgh" > Unb.To_Unbounded_String("ABCDEFGH")) or + Unb.Null_Unbounded_String > Null_String + then + Report.Failed("Incorrect results from function "">"" with " & + "string - unbounded string parameter combinations"); + end if; + + + -- Function ">=" + + TC_Unb_String := Unb.To_Unbounded_String(TC_String); + + if not (TC_Unb_String >= TC_String and + Null_String >= Unb.Null_Unbounded_String and + "test" >= Unb.To_Unbounded_String("tess") and + Unb.To_Unbounded_String("Programming") >= "PROGRAMMING") + then + Report.Failed("Incorrect results from function "">="" with " & + "string - unbounded string parameter combinations"); + 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 CXA4031; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4032.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4032.a new file mode 100644 index 000000000..031d01c6c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4032.a @@ -0,0 +1,457 @@ +-- CXA4032.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 procedures defined in package Ada.Strings.Unbounded +-- are available, and that they produce correct results. Specifically, +-- check the procedures Replace_Slice, Insert, Overwrite, Delete, +-- Trim (2 versions), Head, and Tail. +-- +-- TEST DESCRIPTION: +-- This test demonstrates the uses of many of the procedures defined +-- in package Ada.Strings.Unbounded for use with unbounded strings. +-- The test simulates how unbounded strings could be processed in a +-- user environment, using the procedures provided in this package. +-- +-- This test, when taken in conjunction with tests CXA4010, CXA4011, +-- CXA4030, and CXA4031 will constitute a test of all the functionality +-- contained in package Ada.Strings.Unbounded. This test uses a variety +-- of the procedures defined in the unbounded string package in ways +-- typical of common usage. +-- +-- +-- CHANGE HISTORY: +-- 02 Mar 95 SAIC Initial prerelease version. +-- +--! + +with Report; +with Ada.Strings; +with Ada.Strings.Maps; +with Ada.Strings.Maps.Constants; +with Ada.Strings.Unbounded; + +procedure CXA4032 is +begin + + Report.Test ("CXA4032", "Check that the subprograms defined in " & + "package Ada.Strings.Unbounded are available, " & + "and that they produce correct results"); + + Test_Block: + declare + + package Unb renames Ada.Strings.Unbounded; + use Unb; + use Ada.Strings; + + TC_Null_String : constant String := ""; + TC_String_5 : String(1..5) := "ABCDE"; + + TC_Unb_String : Unb.Unbounded_String := + Unb.To_Unbounded_String("Test String"); + + begin + + -- Procedure Replace_Slice + + begin -- Low > Source'Last+1 + Unb.Replace_Slice(Source => TC_Unb_String, + Low => Unb.Length(TC_Unb_String) + 2, + High => Unb.Length(TC_Unb_String), + By => TC_String_5); + Report.Failed("Index_Error not raised by Replace_Slice when Low " & + "> Source'Last+1"); + exception + when Index_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by Replace_Slice" & + "when Low > Source'Last+1"); + end; + + -- High >= Low + + TC_Unb_String := Unb.To_Unbounded_String("Test String"); + + Unb.Replace_Slice(TC_Unb_String, 5, 5, TC_String_5); + + if TC_Unb_String /= Unb.To_Unbounded_String("TestABCDEString") then + Report.Failed("Incorrect results from Replace_Slice - 1"); + end if; + + Unb.Replace_Slice(TC_Unb_String, 1, 4, TC_String_5); + + if TC_Unb_String /= Unb.To_Unbounded_String("ABCDEABCDEString") then + Report.Failed("Incorrect results from Replace_Slice - 2"); + end if; + + Unb.Replace_Slice(TC_Unb_String, + 11, + Unb.Length(TC_Unb_String), + TC_Null_String); + + if TC_Unb_String /= Unb.To_Unbounded_String("ABCDEABCDE") then + Report.Failed("Incorrect results from Replace_Slice - 3"); + end if; + + -- High < Low + + Unb.Replace_Slice(TC_Unb_String, Low => 4, High => 1, By => "xxx"); + + if TC_Unb_String /= Unb.To_Unbounded_String("ABCxxxDEABCDE") then + Report.Failed("Incorrect results from Replace_Slice - 4"); + end if; + + Unb.Replace_Slice(TC_Unb_String, Low => 1, High => 0, By => "yyy"); + + if TC_Unb_String /= Unb.To_Unbounded_String("yyyABCxxxDEABCDE") then + Report.Failed("Incorrect results from Replace_Slice - 5"); + end if; + + Unb.Replace_Slice(TC_Unb_String, + Unb.Length(TC_Unb_String) + 1, + Unb.Length(TC_Unb_String), + By => "zzz"); + + if TC_Unb_String /= Unb.To_Unbounded_String("yyyABCxxxDEABCDEzzz") then + Report.Failed("Incorrect results from Replace_Slice - 6"); + end if; + + + -- Procedure Insert + + TC_Unb_String := Unb.To_Unbounded_String("Test String"); + + begin -- Before not in Source'First..Source'Last + 1 + Unb.Insert(Source => TC_Unb_String, + Before => Unb.Length(TC_Unb_String) + 2, + New_Item => TC_String_5); + Report.Failed("Index_Error not raised by Insert when Before " & + "not in the range Source'First..Source'Last+1"); + exception + when Index_Error => null; -- OK, expected exception. + when others => + Report.Failed + ("Unexpected exception raised by Insert when Before not in " & + "the range Source'First..Source'Last+1"); + end; + + Unb.Insert(TC_Unb_String, 1, "**"); + + if TC_Unb_String /= Unb.To_Unbounded_String("**Test String") then + Report.Failed("Incorrect results from Insert - 1"); + end if; + + Unb.Insert(TC_Unb_String, Unb.Length(TC_Unb_String)+1, "**"); + + if TC_Unb_String /= Unb.To_Unbounded_String("**Test String**") then + Report.Failed("Incorrect results from Insert - 2"); + end if; + + Unb.Insert(TC_Unb_String, 8, "---"); + + if TC_Unb_String /= Unb.To_Unbounded_String("**Test ---String**") then + Report.Failed("Incorrect results from Insert - 3"); + end if; + + Unb.Insert(TC_Unb_String, 3, TC_Null_String); + + if TC_Unb_String /= Unb.To_Unbounded_String("**Test ---String**") then + Report.Failed("Incorrect results from Insert - 4"); + end if; + + + -- Procedure Overwrite + + begin -- Position not in Source'First..Source'Last + 1 + Unb.Overwrite(Source => TC_Unb_String, + Position => Unb.Length(TC_Unb_String) + 2, + New_Item => TC_String_5); + Report.Failed("Index_Error not raised by Overwrite when Position " & + "not in the range Source'First..Source'Last+1"); + exception + when Index_Error => null; -- OK, expected exception. + when others => + Report.Failed + ("Unexpected exception raised by Overwrite when Position not " & + "in the range Source'First..Source'Last+1"); + end; + + TC_Unb_String := Unb.To_Unbounded_String("Test String"); + + Unb.Overwrite(Source => TC_Unb_String, + Position => 1, + New_Item => "XXXX"); + + if TC_Unb_String /= Unb.To_Unbounded_String("XXXX String") then + Report.Failed("Incorrect results from Overwrite - 1"); + end if; + + Unb.Overwrite(TC_Unb_String, Unb.Length(TC_Unb_String)+1, "**"); + + if TC_Unb_String /= Unb.To_Unbounded_String("XXXX String**") then + Report.Failed("Incorrect results from Overwrite - 2"); + end if; + + Unb.Overwrite(TC_Unb_String, 3, TC_Null_String); + + if TC_Unb_String /= Unb.To_Unbounded_String("XXXX String**") then + Report.Failed("Incorrect results from Overwrite - 3"); + end if; + + Unb.Overwrite(TC_Unb_String, 1, "abcdefghijklmn"); + + if TC_Unb_String /= Unb.To_Unbounded_String("abcdefghijklmn") then + Report.Failed("Incorrect results from Overwrite - 4"); + end if; + + + -- Procedure Delete + + TC_Unb_String := Unb.To_Unbounded_String("Test String"); + + -- From > Through (No change to Source) + + Unb.Delete(Source => TC_Unb_String, + From => Unb.Length(TC_Unb_String), + Through => Unb.Length(TC_Unb_String)-1); + + if TC_Unb_String /= Unb.To_Unbounded_String("Test String") then + Report.Failed("Incorrect results from Delete - 1"); + end if; + + Unb.Delete(TC_Unb_String, 1, 0); + + if TC_Unb_String /= Unb.To_Unbounded_String("Test String") then + Report.Failed("Incorrect results from Delete - 2"); + end if; + + -- From <= Through + + Unb.Delete(TC_Unb_String, 1, 5); + + if TC_Unb_String /= Unb.To_Unbounded_String("String") then + Report.Failed("Incorrect results from Delete - 3"); + end if; + + Unb.Delete(TC_Unb_String, 3, 3); + + if TC_Unb_String /= Unb.To_Unbounded_String("Sting") then + Report.Failed("Incorrect results from Delete - 4"); + end if; + + + -- Procedure Trim + + TC_Unb_String := Unb.To_Unbounded_String("No Spaces"); + + Unb.Trim(Source => TC_Unb_String, Side => Ada.Strings.Both); + + if TC_Unb_String /= Unb.To_Unbounded_String("No Spaces") then + Report.Failed("Incorrect results from Trim - 1"); + end if; + + TC_Unb_String := Unb.To_Unbounded_String(" Leading Spaces "); + + Unb.Trim(TC_Unb_String, Ada.Strings.Left); + + if TC_Unb_String /= Unb.To_Unbounded_String("Leading Spaces ") then + Report.Failed("Incorrect results from Trim - 2"); + end if; + + TC_Unb_String := Unb.To_Unbounded_String(" Ending Spaces "); + + Unb.Trim(TC_Unb_String, Ada.Strings.Right); + + if TC_Unb_String /= Unb.To_Unbounded_String(" Ending Spaces") then + Report.Failed("Incorrect results from Trim - 3"); + end if; + + TC_Unb_String := + Unb.To_Unbounded_String(" Spaces on both ends "); + + Unb.Trim(TC_Unb_String, Ada.Strings.Both); + + if TC_Unb_String /= + Unb.To_Unbounded_String("Spaces on both ends") + then + Report.Failed("Incorrect results from Trim - 4"); + end if; + + + -- Procedure Trim (with Character Set parameters) + + TC_Unb_String := Unb.To_Unbounded_String("lowerCASEletters"); + + Unb.Trim(Source => TC_Unb_String, + Left => Ada.Strings.Maps.Constants.Lower_Set, + Right => Ada.Strings.Maps.Constants.Lower_Set); + + if TC_Unb_String /= Unb.To_Unbounded_String("CASE") then + Report.Failed("Incorrect results from Trim with Sets - 1"); + end if; + + TC_Unb_String := Unb.To_Unbounded_String("lowerCASEletters"); + + Unb.Trim(TC_Unb_String, + Ada.Strings.Maps.Constants.Upper_Set, + Ada.Strings.Maps.Constants.Upper_Set); + + if TC_Unb_String /= Unb.To_Unbounded_String("lowerCASEletters") then + Report.Failed("Incorrect results from Trim with Sets - 2"); + end if; + + TC_Unb_String := Unb.To_Unbounded_String("012abcdefghGFEDCBA789ab"); + + Unb.Trim(TC_Unb_String, + Ada.Strings.Maps.Constants.Hexadecimal_Digit_Set, + Ada.Strings.Maps.Constants.Hexadecimal_Digit_Set); + + if TC_Unb_String /= Unb.To_Unbounded_String("ghG") then + Report.Failed("Incorrect results from Trim with Sets - 3"); + end if; + + + -- Procedure Head + + -- Count <= Source'Length + + TC_Unb_String := Unb.To_Unbounded_String("Test String"); + + Unb.Head(Source => TC_Unb_String, + Count => 0, + Pad => '*'); + + if TC_Unb_String /= Unb.Null_Unbounded_String then + Report.Failed("Incorrect results from Head - 1"); + end if; + + TC_Unb_String := Unb.To_Unbounded_String("Test String"); + + Unb.Head(Source => TC_Unb_String, + Count => 4, + Pad => '*'); + + if TC_Unb_String /= Unb.To_Unbounded_String("Test") then + Report.Failed("Incorrect results from Head - 2"); + end if; + + TC_Unb_String := Unb.To_Unbounded_String("Test String"); + + Unb.Head(Source => TC_Unb_String, + Count => Unb.Length(TC_Unb_String), + Pad => '*'); + + if TC_Unb_String /= Unb.To_Unbounded_String("Test String") then + Report.Failed("Incorrect results from Head - 3"); + end if; + + -- Count > Source'Length + + TC_Unb_String := Unb.To_Unbounded_String("Test String"); + + Unb.Head(Source => TC_Unb_String, + Count => Unb.Length(TC_Unb_String) + 4, + Pad => '*'); + + if TC_Unb_String /= Unb.To_Unbounded_String("Test String****") then + Report.Failed("Incorrect results from Head - 4"); + end if; + + TC_Unb_String := Unb.Null_Unbounded_String; + + Unb.Head(Source => TC_Unb_String, + Count => Unb.Length(TC_Unb_String) + 3, + Pad => '*'); + + if TC_Unb_String /= Unb.To_Unbounded_String("***") then + Report.Failed("Incorrect results from Head - 5"); + end if; + + + -- Procedure Tail + + -- Count <= Source'Length + + TC_Unb_String := Unb.To_Unbounded_String("Test String"); + + Unb.Tail(Source => TC_Unb_String, + Count => 0, + Pad => '*'); + + if TC_Unb_String /= Unb.Null_Unbounded_String then + Report.Failed("Incorrect results from Tail - 1"); + end if; + + TC_Unb_String := Unb.To_Unbounded_String("Test String"); + + Unb.Tail(Source => TC_Unb_String, + Count => 6, + Pad => '*'); + + if TC_Unb_String /= Unb.To_Unbounded_String("String") then + Report.Failed("Incorrect results from Tail - 2"); + end if; + + TC_Unb_String := Unb.To_Unbounded_String("Test String"); + + Unb.Tail(Source => TC_Unb_String, + Count => Unb.Length(TC_Unb_String), + Pad => '*'); + + if TC_Unb_String /= Unb.To_Unbounded_String("Test String") then + Report.Failed("Incorrect results from Tail - 3"); + end if; + + -- Count > Source'Length + + TC_Unb_String := Unb.To_Unbounded_String("Test String"); + + Unb.Tail(Source => TC_Unb_String, + Count => Unb.Length(TC_Unb_String) + 5, + Pad => 'x'); + + if TC_Unb_String /= Unb.To_Unbounded_String("xxxxxTest String") then + Report.Failed("Incorrect results from Tail - 4"); + end if; + + TC_Unb_String := Unb.Null_Unbounded_String; + + Unb.Tail(Source => TC_Unb_String, + Count => Unb.Length(TC_Unb_String) + 3, + Pad => 'X'); + + if TC_Unb_String /= Unb.To_Unbounded_String("XXX") then + Report.Failed("Incorrect results from Tail - 5"); + end if; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + +end CXA4032; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4033.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4033.a new file mode 100644 index 000000000..8f39b4cff --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4033.a @@ -0,0 +1,405 @@ +-- CXA4033.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 functionality found in packages Ada.Strings.Wide_Maps, +-- Ada.Strings.Wide_Unbounded, and Ada.Strings.Wide_Maps.Wide_Constants +-- is available and produces correct results. +-- +-- TEST DESCRIPTION: +-- This test tests the subprograms found in the +-- Ada.Strings.Wide_Unbounded package. It is based on the tests +-- CXA4030-32, which are tests for the complementary "non-wide" +-- packages. +-- +-- The functions found in CXA4033_0 provide mapping capability, when +-- used in conjunction with Wide_Character_Mapping_Function objects. +-- +-- +-- CHANGE HISTORY: +-- 23 Jun 95 SAIC Initial prerelease version. +-- 24 Feb 97 PWB.CTA Removed attempt to create wide string of length +-- Natural'Last +--! + +package CXA4033_0 is + -- Functions used to supply mapping capability. + function Map_To_Lower_Case (From : Wide_Character) return Wide_Character; + function Map_To_Upper_Case (From : Wide_Character) return Wide_Character; +end CXA4033_0; + +with Ada.Characters.Handling; +package body CXA4033_0 is + -- Function Map_To_Lower_Case will return the lower case form of + -- Wide_Characters in the range 'A'..'Z' only, and return the input + -- wide_character otherwise. + + function Map_To_Lower_Case (From : Wide_Character) + return Wide_Character is + begin + return Ada.Characters.Handling.To_Wide_Character( + Ada.Characters.Handling.To_Lower( + Ada.Characters.Handling.To_Character(From))); + end Map_To_Lower_Case; + + -- Function Map_To_Upper_Case will return the upper case form of + -- Wide_Characters in the range 'a'..'z', or whose position is in one + -- of the ranges 223..246 or 248..255, provided the wide_character has + -- an upper case form. + + function Map_To_Upper_Case (From : Wide_Character) + return Wide_Character is + begin + return Ada.Characters.Handling.To_Wide_Character( + Ada.Characters.Handling.To_Upper( + Ada.Characters.Handling.To_Character(From))); + end Map_To_Upper_Case; + +end CXA4033_0; + + +with CXA4033_0; +with Report; +with Ada.Characters.Handling; +with Ada.Characters.Latin_1; +with Ada.Strings; +with Ada.Strings.Wide_Maps; +with Ada.Strings.Wide_Maps.Wide_Constants; +with Ada.Strings.Wide_Fixed; +with Ada.Strings.Wide_Unbounded; + +procedure CXA4033 is +begin + Report.Test ("CXA4033", + "Check that subprograms defined in the package " & + "Ada.Strings.Wide_Unbounded produce correct results"); + + Test_Block: + declare + + package ACL1 renames Ada.Characters.Latin_1; + package Unb renames Ada.Strings.Wide_Unbounded; + + subtype LC_Characters is Wide_Character range 'a'..'z'; + + use Ada.Characters, Ada.Strings, Unb; + use type Wide_Maps.Wide_Character_Set; + + TC_String : constant Wide_String := "A Standard String"; + + String_20 : Wide_String(1..20) := "ABCDEFGHIJKLMNOPQRST"; + String_40 : Wide_String(1..40) := "abcdefghijklmnopqrst" & + String_20; + String_80 : Wide_String(1..80) := String_40 & String_40; + TC_String_5 : Wide_String(1..5) := "ABCDE"; + TC_Unb_String : Unbounded_Wide_String := Null_Unbounded_Wide_String; + + -- The following strings are used in examination of the Translation + -- subprograms. + New_Character_String : Wide_String(1..10) := + Handling.To_Wide_String( + ACL1.LC_A_Grave & ACL1.LC_A_Ring & ACL1.LC_AE_Diphthong & + ACL1.LC_C_Cedilla & ACL1.LC_E_Acute & ACL1.LC_I_Circumflex & + ACL1.LC_Icelandic_Eth & ACL1.LC_N_Tilde & + ACL1.LC_O_Oblique_Stroke & ACL1.LC_Icelandic_Thorn); + + TC_New_Character_String : Wide_String(1..10) := + Handling.To_Wide_String( + ACL1.UC_A_Grave & ACL1.UC_A_Ring & ACL1.UC_AE_Diphthong & + ACL1.UC_C_Cedilla & ACL1.UC_E_Acute & ACL1.UC_I_Circumflex & + ACL1.UC_Icelandic_Eth & ACL1.UC_N_Tilde & + ACL1.UC_O_Oblique_Stroke & ACL1.UC_Icelandic_Thorn); + + New_UB_Character_String : Unbounded_Wide_String := + To_Unbounded_Wide_String(New_Character_String); + + TC_New_UB_Character_String : Unbounded_Wide_String := + To_Unbounded_Wide_String(TC_New_Character_String); + + -- Access objects that will be provided as parameters to the + -- subprograms. + Map_To_Lower_Case_Ptr : Wide_Maps.Wide_Character_Mapping_Function := + CXA4033_0.Map_To_Lower_Case'Access; + Map_To_Upper_Case_Ptr : Wide_Maps.Wide_Character_Mapping_Function := + CXA4033_0.Map_To_Upper_Case'Access; + + begin + + -- Testing functionality found in Package Ada.Strings.Wide_Unbounded. + -- + -- Function Index. + + if Index(To_Unbounded_Wide_String("AAABBBaaabbb"), + "aabb", + Mapping => Map_To_Lower_Case_Ptr) /= 2 or + Index(To_Unbounded_Wide_String("Case of a Mixed Case String"), + "case", + Ada.Strings.Backward, + Map_To_Lower_Case_Ptr) /= 17 + then + Report.Failed("Incorrect results from Function Index, " & + "using a Wide Character Mapping Function parameter"); + end if; + + -- Function Count. + if Count(Source => To_Unbounded_Wide_String("ABABABA"), + Pattern => "aba", + Mapping => Map_To_Lower_Case_Ptr) /= 2 or + Count(Null_Unbounded_Wide_String, "mat", Map_To_Upper_Case_Ptr) /= 0 + then + Report.Failed("Incorrect results from Function Count, using " & + "a Character Mapping Function parameter"); + end if; + + -- Function Translate. + if Translate(To_Unbounded_Wide_String("A Sample Mixed Case String"), + Mapping => Map_To_Lower_Case_Ptr) /= + To_Unbounded_Wide_String("a sample mixed case string") or + Translate(New_UB_Character_String, Map_To_Upper_Case_Ptr) /= + TC_New_UB_Character_String + then + Report.Failed("Incorrect results from Function Translate, " & + "using a Character Mapping Function parameter"); + end if; + + -- Procedure Translate. + declare + use Ada.Characters.Handling; + Str : Unbounded_Wide_String := + To_Unbounded_Wide_String("AN ALL UPPER CASE STRING"); + begin + Translate(Source => Str, Mapping => Map_To_Lower_Case_Ptr); + if Str /= To_Unbounded_Wide_String("an all upper case string") then + Report.Failed("Incorrect result from Procedure Translate 1"); + end if; + + Translate(New_UB_Character_String, Map_To_Upper_Case_Ptr); + if New_UB_Character_String /= TC_New_UB_Character_String then + Report.Failed("Incorrect result from Procedure Translate 2"); + end if; + end; + + -- Function To_Unbounded_Wide_String (version with Length parameter) + if Length(To_Unbounded_Wide_String(Length => 10)) /= 10 or + Length(To_Unbounded_Wide_String(0)) /= 0 or + Length( To_Unbounded_Wide_String(10) & + To_Unbounded_Wide_String(1) & + To_Unbounded_Wide_String(0) ) /= 10 + 1 + 0 + then + Report.Failed + ("Incorrect results from Function To_Unbounded_Wide_String " & + "with Length parameter"); + end if; + + -- Procedure Append (Wide_Unbounded - Wide_Unbounded) + TC_Unb_String := Null_Unbounded_Wide_String; + Append(TC_Unb_String, To_Unbounded_Wide_String("New Unbounded String")); + if TC_Unb_String /= To_Unbounded_Wide_String("New Unbounded String") + then + Report.Failed("Incorrect results from Procedure Append with " & + "unbounded wide string parameters"); + end if; + + + -- Procedure Append (Wide_Unbounded - Wide_String) + TC_Unb_String := To_Unbounded_Wide_String("An Unbounded String and "); + Append(Source => TC_Unb_String, New_Item => TC_String); + if TC_Unb_String /= + To_Unbounded_Wide_String("An Unbounded String and A Standard String") + then + Report.Failed("Incorrect results from Procedure Append with " & + "an unbounded wide string parameter and a wide " & + "string parameter"); + end if; + + -- Procedure Append (Wide_Unbounded - Wide_Character) + TC_Unb_String := To_Unbounded_Wide_String("Lower Case = "); + for i in LC_Characters'Range loop + Append(Source => TC_Unb_String, New_Item => LC_Characters(i)); + end loop; + if TC_Unb_String /= + Unb.To_Unbounded_Wide_String + ("Lower Case = abcdefghijklmnopqrstuvwxyz") + then + Report.Failed("Incorrect results from Procedure Append with " & + "an unbounded wide string parameter and a wide " & + "character parameter"); + end if; + + -- Function "=" + TC_Unb_String := To_Unbounded_Wide_String(TC_String); + if not (TC_Unb_String = TC_String) or + not "="("A Standard String", TC_Unb_String) or + not ((Null_Unbounded_Wide_String = "") and + ("Test String" = To_Unbounded_Wide_String("Test String"))) + then + Report.Failed("Incorrect results from Function ""="" with " & + "wide_string - unbounded wide string parameters"); + end if; + + -- Function "<" + if not ("Extra Space" < To_Unbounded_Wide_String("Extra Space ") and + To_Unbounded_Wide_String("tess") < "test" and + To_Unbounded_Wide_String("best") < "test") + then + Report.Failed("Incorrect results from Function ""<"" with " & + "wide string - unbounded wide string parameters"); + end if; + + -- Function "<=" + TC_Unb_String := To_Unbounded_Wide_String("Sample string"); + if TC_Unb_String <= "Sample strin" or + not("Sample string" <= TC_Unb_String) + then + Report.Failed("Incorrect results from Function ""<="" with " & + "wide string - unbounded wide string parameters"); + end if; + + -- Function ">" + TC_Unb_String := To_Unbounded_Wide_String("A MUCH LONGER STRING"); + if not ("A much longer string" > TC_Unb_String and + To_Unbounded_Wide_String(TC_String) > "A Standard Strin" and + "abcdefgh" > To_Unbounded_Wide_String("ABCDEFGH")) + then + Report.Failed("Incorrect results from Function "">"" with " & + "wide string - unbounded wide string parameters"); + end if; + + -- Function ">=" + TC_Unb_String := To_Unbounded_Wide_String(TC_String); + if not (TC_Unb_String >= TC_String and + "test" >= To_Unbounded_Wide_String("tess") and + To_Unbounded_Wide_String("Programming") >= "PROGRAMMING") + then + Report.Failed("Incorrect results from Function "">="" with " & + "wide string - unbounded wide string parameters"); + end if; + + -- Procedure Replace_Slice + TC_Unb_String := To_Unbounded_Wide_String("Test String"); + Replace_Slice(TC_Unb_String, 5, 5, TC_String_5); + if TC_Unb_String /= To_Unbounded_Wide_String("TestABCDEString") then + Report.Failed("Incorrect results from Replace_Slice - 1"); + end if; + + Replace_Slice(TC_Unb_String, 1, 4, TC_String_5); + if TC_Unb_String /= To_Unbounded_Wide_String("ABCDEABCDEString") then + Report.Failed("Incorrect results from Replace_Slice - 2"); + end if; + + -- Procedure Insert + TC_Unb_String := To_Unbounded_Wide_String("Test String"); + Insert(TC_Unb_String, 1, "**"); + if TC_Unb_String /= To_Unbounded_Wide_String("**Test String") then + Report.Failed("Incorrect results from Procedure Insert - 1"); + end if; + + Insert(TC_Unb_String, Length(TC_Unb_String)+1, "**"); + if TC_Unb_String /= To_Unbounded_Wide_String("**Test String**") then + Report.Failed("Incorrect results from Procedure Insert - 2"); + end if; + + -- Procedure Overwrite + TC_Unb_String := To_Unbounded_Wide_String("Test String"); + Overwrite(TC_Unb_String, 1, New_Item => "XXXX"); + if TC_Unb_String /= To_Unbounded_Wide_String("XXXX String") then + Report.Failed("Incorrect results from Procedure Overwrite - 1"); + end if; + + Overwrite(TC_Unb_String, Length(TC_Unb_String)+1, "**"); + if TC_Unb_String /= To_Unbounded_Wide_String("XXXX String**") then + Report.Failed("Incorrect results from Procedure Overwrite - 2"); + end if; + + -- Procedure Delete + TC_Unb_String := To_Unbounded_Wide_String("Test String"); + Delete(TC_Unb_String, 1, 0); + if TC_Unb_String /= To_Unbounded_Wide_String("Test String") then + Report.Failed("Incorrect results from Procedure Delete - 1"); + end if; + + Delete(TC_Unb_String, 1, 5); + if TC_Unb_String /= To_Unbounded_Wide_String("String") then + Report.Failed("Incorrect results from Procedure Delete - 2"); + end if; + + -- Procedure Trim + TC_Unb_String := To_Unbounded_Wide_String(" Leading Spaces "); + Trim(TC_Unb_String, Ada.Strings.Left); + if TC_Unb_String /= To_Unbounded_Wide_String("Leading Spaces ") then + Report.Failed("Incorrect results from Procedure Trim - 1"); + end if; + + TC_Unb_String := + To_Unbounded_Wide_String(" Spaces on both ends "); + Trim(TC_Unb_String, Ada.Strings.Both); + if TC_Unb_String /= + To_Unbounded_Wide_String("Spaces on both ends") + then + Report.Failed("Incorrect results from Procedure Trim - 2"); + end if; + + -- Procedure Trim (with Wide_Character_Set parameters) + TC_Unb_String := To_Unbounded_Wide_String("012abcdefghGFEDCBA789ab"); + Trim(TC_Unb_String, + Ada.Strings.Wide_Maps.Wide_Constants.Hexadecimal_Digit_Set, + Ada.Strings.Wide_Maps.Wide_Constants.Hexadecimal_Digit_Set); + if TC_Unb_String /= To_Unbounded_Wide_String("ghG") then + Report.Failed("Incorrect results from Procedure Trim with Sets"); + end if; + + -- Procedure Head + TC_Unb_String := To_Unbounded_Wide_String("Test String"); + Head(Source => TC_Unb_String, Count => 0, Pad => '*'); + if TC_Unb_String /= Null_Unbounded_Wide_String then + Report.Failed("Incorrect results from Procedure Head - 1"); + end if; + + TC_Unb_String := To_Unbounded_Wide_String("Test String"); + Head(Source => TC_Unb_String, Count => 4, Pad => '*'); + if TC_Unb_String /= To_Unbounded_Wide_String("Test") then + Report.Failed("Incorrect results from Procedure Head - 2"); + end if; + + -- Procedure Tail + TC_Unb_String := To_Unbounded_Wide_String("Test String"); + Tail(Source => TC_Unb_String, Count => 0, Pad => '*'); + if TC_Unb_String /= Null_Unbounded_Wide_String then + Report.Failed("Incorrect results from Procedure Tail - 1"); + end if; + + TC_Unb_String := To_Unbounded_Wide_String("Test String"); + Tail(TC_Unb_String, Length(TC_Unb_String) + 5, 'x'); + if TC_Unb_String /= To_Unbounded_Wide_String("xxxxxTest String") then + Report.Failed("Incorrect results from Procedure Tail - 2"); + end if; + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + +end CXA4033; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4034.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4034.a new file mode 100644 index 000000000..a1ed53de0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4034.a @@ -0,0 +1,281 @@ +-- CXA4034.A +-- +-- Grant of Unlimited Rights +-- +-- The Ada Conformity Assessment Authority (ACAA) holds unlimited +-- rights in the software and documentation contained herein. Unlimited +-- rights are the same as those granted by the U.S. Government for older +-- parts of the Ada Conformity Assessment Test Suite, and are defined +-- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA +-- intends to confer upon all recipients unlimited rights equal to those +-- held by the ACAA. 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 Ada.Strings.Bounded.Slice raises Index_Error if +-- High > Length (Source) or Low > Length (Source) + 1. +-- (Defect Report 8652/0049). +-- +-- Check that Ada.Strings.Wide_Bounded.Slice raises Index_Error if +-- High > Length (Source) or Low > Length (Source) + 1. +-- +-- CHANGE HISTORY: +-- 12 FEB 2001 PHL Initial version +-- 14 MAR 2001 RLB Added Wide_Bounded subtest. +-- +--! +with Ada.Exceptions; +use Ada.Exceptions; +with Ada.Strings.Bounded; +with Ada.Strings.Wide_Bounded; +use Ada.Strings; +with Report; +use Report; +procedure CXA4034 is + + package Bs is new Ada.Strings.Bounded.Generic_Bounded_Length (40); + + package WBs is new Ada.Strings.Wide_Bounded.Generic_Bounded_Length (32); + + Source : String (Ident_Int (1) .. Ident_Int (30)); + + Wide_Source : Wide_String (Ident_Int (1) .. Ident_Int (24)); + + X : Bs.Bounded_String; + + WX : WBs.Bounded_Wide_String; + +begin + Test ("CXA4034", + "Check that Slice raises Index_Error if either Low or High is " & + "greater than the Length(Source) for Ada.Strings.Bounded and " & + "Ada.Strings.Wide_Bounded"); + + -- Fill Source with "ABC..." + for I in Source'Range loop + Source (I) := Ident_Char (Character'Val (I + + Character'Pos ('A') - Source'First)); + end loop; + -- and W with "ABC..." + for I in Wide_Source'Range loop + Wide_Source (I) := Ident_Wide_Char (Wide_Character'Val (I + + Wide_Character'Pos ('A') - Wide_Source'First)); + end loop; + + X := Bs.To_Bounded_String (Source); + + begin + declare + S : constant String := + Bs.Slice (X, Low => Ident_Int (28), High => Ident_Int (41)); + begin + Failed ("No exception raised by Slice - 1"); + if S = Source then + Comment ("Don't optimize S"); + end if; + end; + exception + when Index_Error => + null; -- Expected exception. + when E: others => + Failed ("Exception raised - " & Exception_Name (E) & + " - " & Exception_Message (E) & " - 1"); + end; + + begin + declare + S : constant String := + Bs.Slice (X, Low => Ident_Int (8), High => Ident_Int (31)); + begin + Failed ("No exception raised by Slice - 2"); + if S = Source then + Comment ("Don't optimize S"); + end if; + end; + exception + when Index_Error => + null; -- Expected exception. + when E: others => + Failed ("Exception raised - " & Exception_Name (E) & + " - " & Exception_Message (E) & " - 2"); + end; + + begin + declare + S : constant String := + Bs.Slice (X, Low => Ident_Int (15), High => Ident_Int (30)); + begin + if S /= Source(15..30) then + Failed ("Wrong result - 3"); + end if; + end; + exception + when E: others => + Failed ("Exception raised - " & Exception_Name (E) & + " - " & Exception_Message (E) & " - 3"); + end; + + begin + declare + S : constant String := + Bs.Slice (X, Low => Ident_Int (42), High => Ident_Int (28)); + begin + Failed ("No exception raised by Slice - 4"); + if S = Source then + Comment ("Don't optimize S"); + end if; + end; + exception + when Index_Error => + null; -- Expected exception. + when E: others => + Failed ("Exception raised - " & Exception_Name (E) & + " - " & Exception_Message (E) & " - 4"); + end; + + begin + declare + S : constant String := + Bs.Slice (X, Low => Ident_Int (31), High => Ident_Int (28)); + begin + if S /= "" then + Failed ("Wrong result - 5"); + end if; + end; + exception + when E: others => + Failed ("Exception raised - " & Exception_Name (E) & + " - " & Exception_Message (E) & " - 5"); + end; + + begin + declare + S : constant String := + Bs.Slice (X, Low => Ident_Int (30), High => Ident_Int (30)); + begin + if S /= Source(30..30) then + Failed ("Wrong result - 6"); + end if; + end; + exception + when E: others => + Failed ("Exception raised - " & Exception_Name (E) & + " - " & Exception_Message (E) & " - 6"); + end; + + WX := WBs.To_Bounded_Wide_String (Wide_Source); + + begin + declare + W : constant Wide_String := + WBs.Slice (WX, Low => Ident_Int (21), High => Ident_Int (33)); + begin + Failed ("No exception raised by Slice - 7"); + if W = Wide_Source then + Comment ("Don't optimize W"); + end if; + end; + exception + when Index_Error => + null; -- Expected exception. + when E: others => + Failed ("Exception raised - " & Exception_Name (E) & + " - " & Exception_Message (E) & " - 7"); + end; + + begin + declare + W : constant Wide_String := + WBs.Slice (WX, Low => Ident_Int (8), High => Ident_Int (25)); + begin + Failed ("No exception raised by Slice - 8"); + if W = Wide_Source then + Comment ("Don't optimize W"); + end if; + end; + exception + when Index_Error => + null; -- Expected exception. + when E: others => + Failed ("Exception raised - " & Exception_Name (E) & + " - " & Exception_Message (E) & " - 8"); + end; + + begin + declare + W : constant Wide_String := + WBs.Slice (WX, Low => Ident_Int (15), High => Ident_Int (24)); + begin + if W /= Wide_Source(15..24) then + Failed ("Wrong result - 8"); + end if; + end; + exception + when E: others => + Failed ("Exception raised - " & Exception_Name (E) & + " - " & Exception_Message (E) & " - 9"); + end; + + begin + declare + W : constant Wide_String := + WBs.Slice (WX, Low => Ident_Int (36), High => Ident_Int (20)); + begin + Failed ("No exception raised by Slice - 10"); + if W = Wide_Source then + Comment ("Don't optimize W"); + end if; + end; + exception + when Index_Error => + null; -- Expected exception. + when E: others => + Failed ("Exception raised - " & Exception_Name (E) & + " - " & Exception_Message (E) & " - 10"); + end; + + begin + declare + W : constant Wide_String := + WBs.Slice (WX, Low => Ident_Int (25), High => Ident_Int (21)); + begin + if W /= "" then + Failed ("Wrong result - 11"); + end if; + end; + exception + when E: others => + Failed ("Exception raised - " & Exception_Name (E) & + " - " & Exception_Message (E) & " - 11"); + end; + + begin + declare + W : constant Wide_String := + WBs.Slice (WX, Low => Ident_Int (24), High => Ident_Int (24)); + begin + if W /= Wide_Source(24..24) then + Failed ("Wrong result - 12"); + end if; + end; + exception + when E: others => + Failed ("Exception raised - " & Exception_Name (E) & + " - " & Exception_Message (E) & " - 12"); + end; + + Result; +end CXA4034; + diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa5011.a b/gcc/testsuite/ada/acats/tests/cxa/cxa5011.a new file mode 100644 index 000000000..c9a007e52 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa5011.a @@ -0,0 +1,471 @@ +-- CXA5011.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, for both Float_Random and Discrete_Random packages, +-- the following are true: +-- 1) two objects of type Generator are initialized to the same state. +-- 2) when the Function Reset is used to reset two generators +-- to different time-dependent states, the resulting random values +-- from each generator are different. +-- 3) when the Function Reset uses the same integer initiator +-- to reset two generators to the same state, the resulting random +-- values from each generator are identical. +-- 4) when the Function Reset uses different integer initiator +-- values to reset two generators, the resulting random numbers are +-- different. +-- +-- TEST DESCRIPTION: +-- This test evaluates components of the Ada.Numerics.Float_Random and +-- Ada.Numerics.Discrete_Random packages. +-- This test checks to see that objects of type Generator are initialized +-- to the same state. In addition, the functionality of Function Reset is +-- validated. +-- For each of the objectives above, evaluation of the various generators +-- is performed using each of the following techniques. When the states of +-- two generators are to be compared, each state is saved, then +-- transformed to a bounded-string variable. The bounded-strings can +-- then be compared for equality. In this case, matching bounded-strings +-- are evidence that the states of two generators are the same. +-- In addition, two generators are compared by evaluating a series of +-- random numbers they produce. A matching series of random numbers +-- implies that the generators were in the same state prior to producing +-- the numbers. +-- +-- +-- CHANGE HISTORY: +-- 20 Apr 95 SAIC Initial prerelease version. +-- 07 Jul 95 SAIC Incorporated reviewer comments/suggestions. +-- 22 Apr 96 SAIC Incorporated reviewer comments for ACVC 2.1. +-- 17 Aug 96 SAIC Deleted Subtest #2. +-- 09 Feb 01 RLB Repaired to work on implementations with a 16-bit +-- Integer. + +--! + +with Ada.Exceptions; +with Ada.Numerics.Float_Random; +with Ada.Numerics.Discrete_Random; +with Ada.Strings.Bounded; +with ImpDef; +with Report; + +procedure CXA5011 is +begin + + Report.Test ("CXA5011", "Check the effect of Function Reset on the " & + "state of random number generators"); + + Test_Block: + declare + + use Ada.Exceptions; + use Ada.Numerics; + use Ada.Strings.Bounded; + + -- Declare an modular subtype, and use it to instantiate the discrete + -- random number generator generic package. + + type Discrete_Range is mod 2**(Integer'Size-1); + package Discrete_Package is new Discrete_Random(Discrete_Range); + + -- Declaration of random number generator objects. + + Discrete_Generator_1, + Discrete_Generator_2 : Discrete_Package.Generator; + Float_Generator_1, + Float_Generator_2 : Float_Random.Generator; + + -- Declaration of bounded string packages instantiated with the + -- value of Max_Image_Width constant from each random number generator + -- package, and bounded string variables used to hold the image of + -- random number generator states. + + package Discrete_String_Pack is + new Generic_Bounded_Length(Discrete_Package.Max_Image_Width); + + package Float_String_Pack is + new Generic_Bounded_Length(Float_Random.Max_Image_Width); + + use Discrete_String_Pack, Float_String_Pack; + + TC_Seed : Integer; + TC_Max_Loop_Count : constant Natural := 1000; + Allowed_Matches : constant Natural := 2; + -- + -- In a sequence of TC_Max_Loop_Count random numbers that should + -- not match, some may match by chance. Up to Allowed_Matches + -- numbers may match before the test is considered to fail. + -- + + + procedure Check_Float_State (Gen_1, Gen_2 : Float_Random.Generator; + Sub_Test : Integer; + States_Should_Match : Boolean) is + + use type Float_Random.State; + + State_1, + State_2 : Float_Random.State; + + State_String_1, + State_String_2 : Float_String_Pack.Bounded_String := + Float_String_Pack.Null_Bounded_String; + begin + + Float_Random.Save(Gen => Gen_1, To_State => State_1); + Float_Random.Save(Gen_2, State_2); + + State_String_1 := + Float_String_Pack.To_Bounded_String(Source => + Float_Random.Image(Of_State => State_1)); + + State_String_2 := + Float_String_Pack.To_Bounded_String(Float_Random.Image(State_2)); + + case States_Should_Match is + when True => + if State_1 /= State_2 then + Report.Failed("Subtest #" & Integer'Image(Sub_Test) & + " State values from Float generators " & + "are not the same"); + end if; + if State_String_1 /= State_String_2 then + Report.Failed("Subtest #" & Integer'Image(Sub_Test) & + " State strings from Float generators " & + "are not the same"); + end if; + when False => + if State_1 = State_2 then + Report.Failed("Subtest #" & Integer'Image(Sub_Test) & + " State values from Float generators " & + "are the same"); + end if; + if State_String_1 = State_String_2 then + Report.Failed("Subtest #" & Integer'Image(Sub_Test) & + " State strings from Float generators " & + "are the same"); + end if; + end case; + end Check_Float_State; + + + + procedure Check_Discrete_State (Gen_1, + Gen_2 : Discrete_Package.Generator; + Sub_Test : Integer; + States_Should_Match : Boolean) is + + use type Discrete_Package.State; + + State_1, State_2 : Discrete_Package.State; + + State_String_1, + State_String_2 : Discrete_String_Pack.Bounded_String := + Discrete_String_Pack.Null_Bounded_String; + begin + + Discrete_Package.Save(Gen => Gen_1, + To_State => State_1); + Discrete_Package.Save(Gen_2, To_State => State_2); + + State_String_1 := + Discrete_String_Pack.To_Bounded_String(Source => + Discrete_Package.Image(Of_State => State_1)); + + State_String_2 := + Discrete_String_Pack.To_Bounded_String(Source => + Discrete_Package.Image(Of_State => State_2)); + + case States_Should_Match is + when True => + if State_1 /= State_2 then + Report.Failed("Subtest #" & Integer'Image(Sub_Test) & + " State values from Discrete " & + "generators are not the same"); + end if; + if State_String_1 /= State_String_2 then + Report.Failed("Subtest #" & Integer'Image(Sub_Test) & + " State strings from Discrete " & + "generators are not the same"); + end if; + when False => + if State_1 = State_2 then + Report.Failed("Subtest #" & Integer'Image(Sub_Test) & + " State values from Discrete " & + "generators are the same"); + end if; + if State_String_1 = State_String_2 then + Report.Failed("Subtest #" & Integer'Image(Sub_Test) & + " State strings from Discrete " & + "generators are the same"); + end if; + end case; + end Check_Discrete_State; + + + + procedure Check_Float_Values (Gen_1, Gen_2 : Float_Random.Generator; + Sub_Test : Integer; + Values_Should_Match : Boolean) is + Matches : Natural := 0; + Check_Failed : Boolean := False; + begin + case Values_Should_Match is + when True => + for i in 1..TC_Max_Loop_Count loop + if Float_Random.Random(Gen_1) /= Float_Random.Random(Gen_2) + then + Check_Failed := True; + exit; + end if; + end loop; + if Check_Failed then + Report.Failed("Sub_Test # " & Integer'Image(Sub_Test) & + " Random numbers from Float generators " & + "Failed check"); + end if; + when False => + for i in 1..TC_Max_Loop_Count loop + if Float_Random.Random(Gen_1) = Float_Random.Random(Gen_2) + then + Matches := Matches + 1; + end if; + end loop; + end case; + + if (Values_Should_Match and Check_Failed) or + (not Values_Should_Match and Matches > Allowed_Matches) + then + Report.Failed("Sub_Test # " & Integer'Image(Sub_Test) & + " Random numbers from Float generators " & + "Failed check"); + end if; + + end Check_Float_Values; + + + + procedure Check_Discrete_Values (Gen_1, + Gen_2 : Discrete_Package.Generator; + Sub_Test : Integer; + Values_Should_Match : Boolean) is + Matches : Natural := 0; + Check_Failed : Boolean := False; + begin + case Values_Should_Match is + when True => + for i in 1..TC_Max_Loop_Count loop + if Discrete_Package.Random(Gen_1) /= + Discrete_Package.Random(Gen_2) + then + Check_Failed := True; + exit; + end if; + end loop; + when False => + for i in 1..TC_Max_Loop_Count loop + if Discrete_Package.Random(Gen_1) = + Discrete_Package.Random(Gen_2) + then + Matches := Matches + 1; + end if; + end loop; + end case; + + if (Values_Should_Match and Check_Failed) or + (not Values_Should_Match and Matches > Allowed_Matches) + then + Report.Failed("Sub_Test # " & Integer'Image(Sub_Test) & + " Random numbers from Discrete generators " & + "Failed check"); + end if; + + end Check_Discrete_Values; + + + + begin + + Sub_Test_1: + -- Check that two objects of type Generator are initialized to the + -- same state. + begin + + -- Since the discrete and float random generators are in the initial + -- state, using Procedure Save to save the states of the generator + -- objects, and transforming these states into strings using + -- Function Image, should yield identical strings. + + Check_Discrete_State (Discrete_Generator_1, + Discrete_Generator_2, + Sub_Test => 1, + States_Should_Match => True); + + Check_Float_State (Float_Generator_1, + Float_Generator_2, + Sub_Test => 1, + States_Should_Match => True); + + -- Since the two random generator objects are in their initial + -- state, the values produced from each (upon calls to Random) + -- should be identical. + + Check_Discrete_Values (Discrete_Generator_1, + Discrete_Generator_2, + Sub_Test => 1, + Values_Should_Match => True); + + Check_Float_Values (Float_Generator_1, + Float_Generator_2, + Sub_Test => 1, + Values_Should_Match => True); + + end Sub_Test_1; + + + + Sub_Test_3: + -- Check that when the Function Reset uses the same integer + -- initiator to reset two generators to the same state, the + -- resulting random values and the state from each generator + -- are identical. + declare + use Discrete_Package, Float_Random; + begin + + -- Reset the generators to the same states, using the version of + -- Function Reset with both generator parameter and initiator + -- specified. + + TC_Seed := Integer(Random(Discrete_Generator_1)); + Reset(Gen => Discrete_Generator_1, Initiator => TC_Seed); + Reset(Discrete_Generator_2, Initiator => TC_Seed); + Reset(Float_Generator_1, TC_Seed); + Reset(Float_Generator_2, TC_Seed); + + -- Since the random generators have been reset to identical states, + -- bounded string images of these states should yield identical + -- strings. + + Check_Discrete_State (Discrete_Generator_1, + Discrete_Generator_2, + Sub_Test => 3, + States_Should_Match => True); + + Check_Float_State (Float_Generator_1, + Float_Generator_2, + Sub_Test => 3, + States_Should_Match => True); + + -- Since the random generators have been reset to identical states, + -- the values produced from each (upon calls to Random) should + -- be identical. + + Check_Discrete_Values (Discrete_Generator_1, + Discrete_Generator_2, + Sub_Test => 3, + Values_Should_Match => True); + + Check_Float_Values (Float_Generator_1, + Float_Generator_2, + Sub_Test => 3, + Values_Should_Match => True); + + end Sub_Test_3; + + + + Sub_Test_4: + -- Check that when the Function Reset uses different integer + -- initiator values to reset two generators, the resulting random + -- numbers and states are different. + begin + + -- Reset the generators to different states. + + TC_Seed := + Integer(Discrete_Package.Random(Discrete_Generator_1)); + + Discrete_Package.Reset(Gen => Discrete_Generator_1, + Initiator => TC_Seed); + + -- Set the seed value to a different value for the second call + -- to Reset. + -- Note: A second call to Random could be made, as above, but that + -- would not ensure that the resulting seed value was + -- different from the first. + + if TC_Seed /= Integer'Last then + TC_Seed := TC_Seed + 1; + else + TC_Seed := TC_Seed - 1; + end if; + + Discrete_Package.Reset(Gen => Discrete_Generator_2, + Initiator => TC_Seed); + + Float_Random.Reset(Float_Generator_1, 16#FF#); -- 255 + Float_Random.Reset(Float_Generator_2, 2#1110_0000#); -- 224 + + -- Since the two float random generators are in different + -- states, the bounded string images depicting their states should + -- differ. + + Check_Discrete_State (Discrete_Generator_1, + Discrete_Generator_2, + Sub_Test => 4, + States_Should_Match => False); + + Check_Float_State (Float_Generator_1, + Float_Generator_2, + Sub_Test => 4, + States_Should_Match => False); + + -- Since the two discrete random generator objects were reset + -- to different states, the values produced from each (upon calls + -- to Random) should differ. + + Check_Discrete_Values (Discrete_Generator_1, + Discrete_Generator_2, + Sub_Test => 4, + Values_Should_Match => False); + + Check_Float_Values (Float_Generator_1, + Float_Generator_2, + Sub_Test => 4, + Values_Should_Match => False); + + end Sub_Test_4; + + 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 CXA5011; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa5012.a b/gcc/testsuite/ada/acats/tests/cxa/cxa5012.a new file mode 100644 index 000000000..a286fa71e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa5012.a @@ -0,0 +1,536 @@ +-- CXA5012.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, for both Float_Random and Discrete_Random packages, +-- the following are true: +-- 1) the procedures Save and Reset can be used to save the +-- specific state of a random number generator, and then restore +-- the specific state to the generator following some intermediate +-- generator activity. +-- 2) the Function Image can be used to obtain a string +-- representation of the state of a generator; and that the +-- Function Value will transform a string representation of the +-- state of a random number generator into the actual state object. +-- 3) a call to Function Value, with a string value that is +-- not the image of any generator state, is a bounded error. This +-- error either raises Constraint_Error or Program_Error, or is +-- accepted. (See Technical Corrigendum 1). +-- +-- TEST DESCRIPTION: +-- This test evaluates components of the Ada.Numerics.Float_Random and +-- Ada.Numerics.Discrete_Random packages. +-- The first objective block of this test uses Procedure Save to +-- save the particular state of a random number generator. The random +-- number generator then generates a series of random numbers. The +-- saved state variable is then used to reset (using Procedure Reset) +-- the generator back to the state it was in at the point of the call +-- to Save. Random values are then generated from this restored +-- generator, and compared with expected values. +-- The second objective block of this test uses Function Image to +-- provide a string representation of a state code. This string is +-- then transformed back to a state code value, and used to reset a +-- random number generator to the saved state. Random values are +-- likewise generated from this restored generator, and compared with +-- expected values. +-- +-- +-- CHANGE HISTORY: +-- 25 Apr 95 SAIC Initial prerelease version. +-- 17 Jul 95 SAIC Incorporated reviewer comments. +-- 17 Dec 97 EDS Change subtype upper limit from 100_000 to 10_000. +-- 16 Sep 99 RLB Updated objective 3 for Technical Corrigendum 1 +-- changes. + +--! + +with Ada.Numerics.Float_Random; +with Ada.Numerics.Discrete_Random; +with Ada.Strings.Bounded; +with ImpDef; +with Report; + +procedure CXA5012 is + +begin + + Report.Test ("CXA5012", "Check the effect of Procedures Save and " & + "Reset, and Functions Image and Value " & + "from the Ada.Numerics.Discrete_Random " & + "and Float_Random packages"); + + Test_Block: + declare + + use Ada.Numerics, Ada.Strings.Bounded; + + -- Declare an integer subtype and an enumeration subtype, and use them + -- to instantiate the discrete random number generator generic package. + + subtype Discrete_Range is Integer range 1..10_000; + type Suit_Of_Cards is (Ace, One, Two, Three, Four, Five, Six, + Seven, Eight, Nine, Ten, Jack, Queen, King); + package Discrete_Pack is new Discrete_Random(Discrete_Range); + package Card_Pack is new Discrete_Random(Suit_Of_Cards); + + -- Declaration of random number generator objects. + + DGen_1, DGen_2 : Discrete_Pack.Generator; + EGen_1, EGen_2 : Card_Pack.Generator; + FGen_1, FGen_2 : Float_Random.Generator; + + -- Variables declared to hold random numbers over the inclusive range + -- of their corresponding type. + + DVal_1, DVal_2 : Discrete_Range; + EVal_1, EVal_2 : Suit_Of_Cards; + FVal_1, FVal_2 : Float_Random.Uniformly_Distributed; + + -- Declaration of State variables used to hold the state of the + -- random number generators. + + DState_1, DState_2 : Discrete_Pack.State; + EState_1, EState_2 : Card_Pack.State; + FState_1, FState_2 : Float_Random.State; + + -- Declaration of bounded string packages instantiated with the + -- value of Max_Image_Width constant, and bounded string variables + -- used to hold the image of random number generator states. + + package DString_Pack is + new Generic_Bounded_Length(Discrete_Pack.Max_Image_Width); + package EString_Pack is + new Generic_Bounded_Length(Card_Pack.Max_Image_Width); + package FString_Pack is + new Generic_Bounded_Length(Float_Random.Max_Image_Width); + + use DString_Pack, EString_Pack, FString_Pack; + + DString_1, DString_2 : DString_Pack.Bounded_String := + DString_Pack.Null_Bounded_String; + EString_1, EString_2 : EString_Pack.Bounded_String := + EString_Pack.Null_Bounded_String; + FString_1, FString_2 : FString_Pack.Bounded_String := + FString_Pack.Null_Bounded_String; + + -- Test variables. + + TC_Count : Natural; + TC_Discrete_Check_Failed, + TC_Enum_Check_Failed, + TC_Float_Check_Failed : Boolean := False; + TC_Seed : Integer; + + begin + + Objective_1: + -- Check that the procedures Save and Reset can be used to save the + -- specific state of a random number generator, and then restore the + -- specific state to the generator following some intermediate + -- generator activity. + declare + + First_Row : constant := 1; + Second_Row : constant := 2; + TC_Max_Values : constant := 100; + + TC_Discrete_Array : array (First_Row..Second_Row, 1..TC_Max_Values) + of Discrete_Range; + TC_Enum_Array : array (First_Row..Second_Row, 1..TC_Max_Values) + of Suit_Of_Cards; + TC_Float_Array : array (First_Row..Second_Row, 1..TC_Max_Values) + of Float_Random.Uniformly_Distributed; + begin + + -- The state of the random number generators are saved to state + -- variables using the procedure Save. + + Discrete_Pack.Save(Gen => DGen_1, To_State => DState_1); + Card_Pack.Save (Gen => EGen_1, To_State => EState_1); + Float_Random.Save (Gen => FGen_1, To_State => FState_1); + + -- Random number generators are used to fill the first half of the + -- first row of the arrays with randomly generated values. + + for i in 1..TC_Max_Values/2 loop + TC_Discrete_Array(First_Row, i) := Discrete_Pack.Random(DGen_1); + TC_Enum_Array(First_Row, i) := Card_Pack.Random(EGen_1); + TC_Float_Array(First_Row, i) := Float_Random.Random(FGen_1); + end loop; + + -- The random number generators are reset to the states saved in the + -- state variables, using the procedure Reset. + + Discrete_Pack.Reset(Gen => DGen_1, From_State => DState_1); + Card_Pack.Reset (Gen => EGen_1, From_State => EState_1); + Float_Random.Reset (Gen => FGen_1, From_State => FState_1); + + -- The same random number generators are used to fill the first half + -- of the second row of the arrays with randomly generated values. + + for i in 1..TC_Max_Values/2 loop + TC_Discrete_Array(Second_Row, i) := Discrete_Pack.Random(DGen_1); + TC_Enum_Array(Second_Row, i) := Card_Pack.Random(EGen_1); + TC_Float_Array(Second_Row, i) := Float_Random.Random(FGen_1); + end loop; + + -- Run the random number generators many times (not using results). + + for i in Discrete_Range'Range loop + DVal_1 := Discrete_Pack.Random(DGen_1); + EVal_1 := Card_Pack.Random(EGen_1); + FVal_1 := Float_Random.Random(FGen_1); + end loop; + + -- The states of the random number generators are saved to state + -- variables using the procedure Save. + + Discrete_Pack.Save(Gen => DGen_1, To_State => DState_1); + Card_Pack.Save(Gen => EGen_1, To_State => EState_1); + Float_Random.Save (Gen => FGen_1, To_State => FState_1); + + -- The last half of the first row of the arrays are filled with + -- values generated from the same random number generators. + + for i in (TC_Max_Values/2 + 1)..TC_Max_Values loop + TC_Discrete_Array(First_Row, i) := Discrete_Pack.Random(DGen_1); + TC_Enum_Array(First_Row, i) := Card_Pack.Random(EGen_1); + TC_Float_Array(First_Row, i) := Float_Random.Random(FGen_1); + end loop; + + -- The random number generators are reset to the states saved in the + -- state variables, using the procedure Reset. + + Discrete_Pack.Reset(Gen => DGen_1, From_State => DState_1); + Card_Pack.Reset(Gen => EGen_1, From_State => EState_1); + Float_Random.Reset (Gen => FGen_1, From_State => FState_1); + + -- The last half of the second row of the arrays are filled with + -- values generated from the same random number generator. + -- These values should exactly mirror the values in the last half + -- of the first row of the arrays that had been previously generated. + + for i in (TC_Max_Values/2 + 1)..TC_Max_Values loop + TC_Discrete_Array(Second_Row, i) := Discrete_Pack.Random(DGen_1); + TC_Enum_Array(Second_Row, i) := Card_Pack.Random(EGen_1); + TC_Float_Array(Second_Row, i) := Float_Random.Random(FGen_1); + end loop; + + -- Check that the values in the two rows of the arrays are identical. + + for i in 1..TC_Max_Values loop + if TC_Discrete_Array(First_Row,i) /= + TC_Discrete_Array(Second_Row,i) + then + TC_Discrete_Check_Failed := True; + exit; + end if; + end loop; + + for i in 1..TC_Max_Values loop + if TC_Enum_Array(First_Row,i) /= TC_Enum_Array(Second_Row,i) then + TC_Enum_Check_Failed := True; + exit; + end if; + end loop; + + for i in 1..TC_Max_Values loop + if TC_Float_Array(First_Row,i) /= TC_Float_Array(Second_Row,i) + then + TC_Float_Check_Failed := True; + exit; + end if; + end loop; + + if TC_Discrete_Check_Failed then + Report.Failed("Discrete random values generated following use " & + "of procedures Save and Reset were not the same"); + TC_Discrete_Check_Failed := False; + end if; + + if TC_Enum_Check_Failed then + Report.Failed("Enumeration random values generated following " & + "use of procedures Save and Reset were not the " & + "same"); + TC_Enum_Check_Failed := False; + end if; + + if TC_Float_Check_Failed then + Report.Failed("Float random values generated following use " & + "of procedures Save and Reset were not the same"); + TC_Float_Check_Failed := False; + end if; + + end Objective_1; + + + + Objective_2: + -- Check that the Function Image can be used to obtain a string + -- representation of the state of a generator. + -- Check that the Function Value will transform a string + -- representation of the state of a random number generator + -- into the actual state object. + begin + + -- Use two discrete and float random number generators to generate + -- a series of values (so that the generators are no longer in their + -- initial states, and they have generated the same number of + -- random values). + + TC_Seed := Integer(Discrete_Pack.Random(DGen_1)); + Discrete_Pack.Reset(DGen_1, TC_Seed); + Discrete_Pack.Reset(DGen_2, TC_Seed); + Card_Pack.Reset (EGen_1, TC_Seed); + Card_Pack.Reset (EGen_2, TC_Seed); + Float_Random.Reset (FGen_1, TC_Seed); + Float_Random.Reset (FGen_2, TC_Seed); + + for i in 1..1000 loop + DVal_1 := Discrete_Pack.Random(DGen_1); + DVal_2 := Discrete_Pack.Random(DGen_2); + EVal_1 := Card_Pack.Random(EGen_1); + EVal_2 := Card_Pack.Random(EGen_2); + FVal_1 := Float_Random.Random(FGen_1); + FVal_2 := Float_Random.Random(FGen_2); + end loop; + + -- Use the Procedure Save to save the states of the generators + -- to state variables. + + Discrete_Pack.Save(Gen => DGen_1, To_State => DState_1); + Discrete_Pack.Save(DGen_2, To_State => DState_2); + Card_Pack.Save (Gen => EGen_1, To_State => EState_1); + Card_Pack.Save (EGen_2, To_State => EState_2); + Float_Random.Save (FGen_1, To_State => FState_1); + Float_Random.Save (FGen_2, FState_2); + + -- Use the Function Image to produce a representation of the state + -- codes as (bounded) string objects. + + DString_1 := DString_Pack.To_Bounded_String( + Discrete_Pack.Image(Of_State => DState_1)); + DString_2 := DString_Pack.To_Bounded_String( + Discrete_Pack.Image(DState_2)); + EString_1 := EString_Pack.To_Bounded_String( + Card_Pack.Image(Of_State => EState_1)); + EString_2 := EString_Pack.To_Bounded_String( + Card_Pack.Image(EState_2)); + FString_1 := FString_Pack.To_Bounded_String( + Float_Random.Image(Of_State => FState_1)); + FString_2 := FString_Pack.To_Bounded_String( + Float_Random.Image(FState_2)); + + -- Compare the bounded string objects for equality. + + if DString_1 /= DString_2 then + Report.Failed("String values returned from Function Image " & + "depict different states of Discrete generators"); + end if; + if EString_1 /= EString_2 then + Report.Failed("String values returned from Function Image " & + "depict different states of Enumeration " & + "generators"); + end if; + if FString_1 /= FString_2 then + Report.Failed("String values returned from Function Image " & + "depict different states of Float generators"); + end if; + + -- The string representation of a state code is transformed back + -- to a state code variable using the Function Value. + + DState_1 := Discrete_Pack.Value(Coded_State => + DString_Pack.To_String(DString_1)); + EState_1 := Card_Pack.Value(EString_Pack.To_String(EString_1)); + FState_1 := Float_Random.Value(FString_Pack.To_String(FString_1)); + + -- One of the (pair of each type of ) generators is used to generate + -- a series of random values, getting them "out of synch" with the + -- specific generation sequence of the other generators. + + for i in 1..100 loop + DVal_1 := Discrete_Pack.Random(DGen_1); + EVal_1 := Card_Pack.Random(EGen_1); + FVal_1 := Float_Random.Random (FGen_1); + end loop; + + -- The "out of synch" generators are reset to the previous state they + -- had when their states were saved, and they should now have the same + -- states as the generators that did not generate the values above. + + Discrete_Pack.Reset(Gen => DGen_1, From_State => DState_1); + Card_Pack.Reset (Gen => EGen_1, From_State => EState_1); + Float_Random.Reset (Gen => FGen_1, From_State => FState_1); + + -- All generators should now be in the same state, so the + -- random values they produce should be the same. + + for i in 1..1000 loop + if Discrete_Pack.Random(DGen_1) /= Discrete_Pack.Random(DGen_2) + then + TC_Discrete_Check_Failed := True; + exit; + end if; + end loop; + + for i in 1..1000 loop + if Card_Pack.Random(EGen_1) /= Card_Pack.Random(EGen_2) then + TC_Enum_Check_Failed := True; + exit; + end if; + end loop; + + for i in 1..1000 loop + if Float_Random.Random(FGen_1) /= Float_Random.Random(FGen_2) + then + TC_Float_Check_Failed := True; + exit; + end if; + end loop; + + if TC_Discrete_Check_Failed then + Report.Failed("Random values generated following use of " & + "procedures Image and Value were not the same " & + "for Discrete generator"); + end if; + if TC_Enum_Check_Failed then + Report.Failed("Random values generated following use of " & + "procedures Image and Value were not the same " & + "for Enumeration generator"); + end if; + if TC_Float_Check_Failed then + Report.Failed("Random values generated following use of " & + "procedures Image and Value were not the same " & + "for Float generator"); + end if; + + end Objective_2; + + + + Objective_3: + -- Check that a call to Function Value, with a string value that is + -- not the image of any generator state, is a bounded error. This + -- error either raises Constraint_Error or Program_Error, or is + -- accepted. (See Technical Corrigendum 1). + declare + Not_A_State : constant String := ImpDef.Non_State_String; + begin + + begin + DState_1 := Discrete_Pack.Value(Not_A_State); + if Not_A_State /= "**NONE**" then + Report.Failed("Exception not raised by Function " & + "Ada.Numerics.Discrete_Random.Value when " & + "provided a string input that does not " & + "represent the state of a random number " & + "generator"); + else + Report.Comment("All strings represent states for Function " & + "Ada.Numerics.Discrete_Random.Value"); + end if; + Discrete_Pack.Reset(DGen_1, DState_1); + exception + when Constraint_Error => null; -- OK, expected exception. + Report.Comment("Constraint_Error raised by Function " & + "Ada.Numerics.Discrete_Random.Value when " & + "provided a string input that does not " & + "represent the state of a random number " & + "generator"); + when Program_Error => -- OK, expected exception. + Report.Comment("Program_Error raised by Function " & + "Ada.Numerics.Discrete_Random.Value when " & + "provided a string input that does not " & + "represent the state of a random number " & + "generator"); + when others => + Report.Failed("Unexpected exception raised by Function " & + "Ada.Numerics.Discrete_Random.Value when " & + "provided a string input that does not " & + "represent the state of a random number " & + "generator"); + end; + + begin + EState_1 := Card_Pack.Value(Not_A_State); + if Not_A_State /= "**NONE**" then + Report.Failed("Exception not raised by Function " & + "Ada.Numerics.Discrete_Random.Value when " & + "provided a string input that does not " & + "represent the state of an enumeration " & + "random number generator"); + else + Report.Comment("All strings represent states for Function " & + "Ada.Numerics.Discrete_Random.Value"); + end if; + Card_Pack.Reset(EGen_1, EState_1); + exception + when Constraint_Error => null; -- OK, expected exception. + when Program_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by Function " & + "Ada.Numerics.Discrete_Random.Value when " & + "provided a string input that does not " & + "represent the state of an enumeration " & + "random number generator"); + end; + + begin + FState_1 := Float_Random.Value(Not_A_State); + if Not_A_State /= "**NONE**" then + Report.Failed("Exception not raised by an " & + "instantiated version of " & + "Ada.Numerics.Float_Random.Value when " & + "provided a string input that does not " & + "represent the state of a random number " & + "generator"); + else + Report.Comment("All strings represent states for Function " & + "Ada.Numerics.Float_Random.Value"); + end if; + Float_Random.Reset(FGen_1, FState_1); + exception + when Constraint_Error => null; -- OK, expected exception. + when Program_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by an " & + "instantiated version of " & + "Ada.Numerics.Float_Random.Value when " & + "provided a string input that does not " & + "represent the state of a random number " & + "generator"); + end; + + end Objective_3; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + +end CXA5012; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa5015.a b/gcc/testsuite/ada/acats/tests/cxa/cxa5015.a new file mode 100644 index 000000000..e1035db27 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa5015.a @@ -0,0 +1,342 @@ +-- CXA5015.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 following representation-oriented attributes are +-- available and that the produce correct results: +-- 'Denorm, 'Signed_Zeros, 'Exponent 'Fraction, 'Compose, 'Scaling, +-- 'Floor, 'Ceiling, 'Rounding, 'Unbiased_Rounding, 'Truncation, +-- 'Remainder, 'Adjacent, 'Copy_Sign, 'Leading_Part, 'Machine, and +-- 'Model_Small. +-- +-- TEST DESCRIPTION: +-- This test checks whether certain attributes of floating point types +-- are available from an implementation. Where attribute correctness +-- can be verified in a straight forward manner, the appropriate checks +-- are included here. However, this test is not intended to ensure the +-- correctness of the results returned from all of the attributes +-- examined in this test; that process will occur in the tests of the +-- Numerics_Annex. +-- +-- +-- CHANGE HISTORY: +-- 26 Jun 95 SAIC Initial prerelease version. +-- 29 Apr 96 SAIC Incorporated reviewer comments for ACVC 2.1. +-- 01 DEC 97 EDS Fix value for checking the S'Adjacent attribute +--! + +with Report; + +procedure CXA5015 is + + subtype Float_Subtype is Float range -10.0..10.0; + type Derived_Float_1 is digits 8; + type Derived_Float_2 is new Derived_Float_1 range -10.0..10.0E10; + + use type Float, Float_Subtype, Derived_Float_1, Derived_Float_2; + + TC_Boolean : Boolean; + TC_Float : Float; + TC_SFloat : Float_Subtype; + TC_DFloat_1 : Derived_Float_1; + TC_DFloat_2 : Derived_Float_2; + TC_Tolerance : Float := 0.001; + + function Not_Equal (Actual_Result, Expected_Result, Tolerance : Float) + return Boolean is + begin + return abs(Actual_Result - Expected_Result) > Tolerance; + end Not_Equal; + + +begin + + Report.Test ("CXA5015", "Check that certain representation-oriented " & + "attributes are available and that they " & + "produce correct results"); + + -- New Representation-Oriented Attributes. + -- + -- Check the S'Denorm attribute. + + TC_Boolean := Float'Denorm; + TC_Boolean := Float_Subtype'Denorm; + TC_Boolean := Derived_Float_1'Denorm; + TC_Boolean := Derived_Float_2'Denorm; + + + -- Check the S'Signed_Zeroes attribute. + + TC_Boolean := Float'Signed_Zeros; + TC_Boolean := Float_Subtype'Signed_Zeros; + TC_Boolean := Derived_Float_1'Signed_Zeros; + TC_Boolean := Derived_Float_2'Signed_Zeros; + + + -- New Primitive Function Attributes. + -- + -- Check the S'Exponent attribute. + + TC_Float := 0.5; + TC_SFloat := 0.99; + TC_DFloat_1 := 2.45; + TC_DFloat_2 := 2.65; + + if Float'Exponent(TC_Float) > Float_Subtype'Exponent(TC_SFloat) or + Float'Exponent(TC_Float) > 2 + then + Report.Failed("Incorrect result from the 'Exponent attribute"); + end if; + + + -- Check the S'Fraction attribute. + + if Not_Equal + (Float'Fraction(TC_Float), + TC_Float * Float(Float'Machine_Radix)**(-Float'Exponent(TC_Float)), + TC_Tolerance) + then + Report.Failed("Incorrect result from the 'Fraction attribute - 1"); + end if; + + if Float'Fraction(TC_Float) < + (1.0/Float(Float'Machine_Radix)) - TC_Tolerance or + Float'Fraction(TC_Float) >= 1.0 - TC_Tolerance + then + Report.Failed("Incorrect result from the 'Fraction attribute - 2"); + end if; + + + -- Check the S'Compose attribute. + + if Not_Equal + (Float'Compose(TC_Float, 3), + TC_Float * Float(Float'Machine_Radix)**(3-Float'Exponent(TC_Float)), + TC_Tolerance) + then + Report.Failed("Incorrect result from the 'Compose attribute"); + end if; + + + -- Check the S'Scaling attribute. + + if Not_Equal + (Float'Scaling(TC_Float, 2), + TC_Float * Float(Float'Machine_Radix)**2, + TC_Tolerance) + then + Report.Failed("Incorrect result from the 'Scaling attribute"); + end if; + + + -- Check the S'Floor attribute. + + TC_Float := 0.99; + TC_SFloat := 1.00; + TC_DFloat_1 := 2.50; + TC_DFloat_2 := -2.50; + + if Float'Floor(TC_Float) /= 0.0 or + Float_Subtype'Floor(TC_SFloat) /= 1.0 or + Derived_Float_1'Floor(TC_DFloat_1) /= 2.0 or + Derived_Float_2'Floor(TC_DFloat_2) /= -3.0 + then + Report.Failed("Incorrect result from the 'Floor attribute"); + end if; + + + -- Check the S'Ceiling attribute. + + TC_Float := 0.99; + TC_SFloat := 1.00; + TC_DFloat_1 := 2.50; + TC_DFloat_2 := -2.99; + + if Float'Ceiling(TC_Float) /= 1.0 or + Float_Subtype'Ceiling(TC_SFloat) /= 1.0 or + Derived_Float_1'Ceiling(TC_DFloat_1) /= 3.0 or + Derived_Float_2'Ceiling(TC_DFloat_2) /= -2.0 + then + Report.Failed("Incorrect result from the 'Ceiling attribute"); + end if; + + + -- Check the S'Rounding attribute. + + TC_Float := 0.49; + TC_SFloat := 1.00; + TC_DFloat_1 := 2.50; + TC_DFloat_2 := -2.50; + + if Float'Rounding(TC_Float) /= 0.0 or + Float_Subtype'Rounding(TC_SFloat) /= 1.0 or + Derived_Float_1'Rounding(TC_DFloat_1) /= 3.0 or + Derived_Float_2'Rounding(TC_DFloat_2) /= -3.0 + then + Report.Failed("Incorrect result from the 'Rounding attribute"); + end if; + + + -- Check the S'Unbiased_Rounding attribute. + + TC_Float := 0.50; + TC_SFloat := 1.50; + TC_DFloat_1 := 2.50; + TC_DFloat_2 := -2.50; + + if Float'Unbiased_Rounding(TC_Float) /= 0.0 or + Float_Subtype'Unbiased_Rounding(TC_SFloat) /= 2.0 or + Derived_Float_1'Unbiased_Rounding(TC_DFloat_1) /= 2.0 or + Derived_Float_2'Unbiased_Rounding(TC_DFloat_2) /= -2.0 + then + Report.Failed("Incorrect result from the 'Unbiased_Rounding " & + "attribute"); + end if; + + + -- Check the S'Truncation attribute. + + TC_Float := -0.99; + TC_SFloat := 1.50; + TC_DFloat_1 := 2.99; + TC_DFloat_2 := -2.50; + + if Float'Truncation(TC_Float) /= 0.0 or + Float_Subtype'Truncation(TC_SFloat) /= 1.0 or + Derived_Float_1'Truncation(TC_DFloat_1) /= 2.0 or + Derived_Float_2'Truncation(TC_DFloat_2) /= -2.0 + then + Report.Failed("Incorrect result from the 'Truncation attribute"); + end if; + + + -- Check the S'Remainder attribute. + + TC_Float := 9.0; + TC_SFloat := 7.5; + TC_DFloat_1 := 5.0; + TC_DFloat_2 := 8.0; + + if Float'Remainder(TC_Float, 2.0) /= 1.0 or + Float_Subtype'Remainder(TC_SFloat, 3.0) /= 1.5 or + Derived_Float_1'Remainder(TC_DFloat_1, 2.0) /= 1.0 or + Derived_Float_2'Remainder(TC_DFloat_2, 4.0) /= 0.0 + then + Report.Failed("Incorrect result from the 'Remainder attribute"); + end if; + + + -- Check the S'Adjacent attribute. + + TC_Float := 4.0; + TC_SFloat := -1.0; + + if Float'Adjacent(TC_Float, TC_Float) /= TC_Float or + Float_Subtype'Adjacent(TC_SFloat, -1.0) /= TC_SFloat + then + Report.Failed("Incorrect result from the 'Adjacent attribute"); + end if; + + + -- Check the S'Copy_Sign attribute. + + TC_Float := 0.0; + TC_SFloat := -1.0; + TC_DFloat_1 := 5.0; + TC_DFloat_2 := -2.5; + + if Float'Copy_Sign(TC_Float, -2.0) /= 0.0 or + Float_Subtype'Copy_Sign(TC_SFloat, 4.0) /= 1.0 or + Derived_Float_1'Copy_Sign(TC_DFloat_1, -2.0) /= -5.0 or + Derived_Float_2'Copy_Sign(TC_DFloat_2, -2.0) /= -2.5 + then + Report.Failed("Incorrect result from the 'Copy_Sign attribute"); + end if; + + + -- Check the S'Leading_Part attribute. + + TC_Float := 0.0; + TC_SFloat := -1.0; + TC_DFloat_1 := 5.88; + TC_DFloat_2 := -2.52; + + -- Leading part obtained in the variables. + TC_Float := Float'Leading_Part(TC_Float, 2); + TC_SFloat := Float_Subtype'Leading_Part(TC_SFloat, 2); + TC_DFloat_1 := Derived_Float_1'Leading_Part(TC_DFloat_1, 2); + TC_DFloat_2 := Derived_Float_2'Leading_Part(TC_DFloat_2, 2); + + -- Checking for the leading part of the variables at this point should + -- produce the same values. + if Float'Leading_Part(TC_Float, 2) /= TC_Float or + Float_Subtype'Leading_Part(TC_SFloat, 2) /= TC_SFloat or + Derived_Float_1'Leading_Part(TC_DFloat_1, 2) /= TC_DFloat_1 or + Derived_Float_2'Leading_Part(TC_DFloat_2, 2) /= TC_DFloat_2 + then + Report.Failed("Incorrect result from the 'Leading_Part attribute"); + end if; + + + -- Check the S'Machine attribute. + + TC_Float := 0.0; + TC_SFloat := -1.0; + TC_DFloat_1 := 5.88; + TC_DFloat_2 := -2.52; + + -- Closest machine number obtained in the variables. + TC_Float := Float'Machine(TC_Float); + TC_SFloat := Float_Subtype'Machine(TC_SFloat); + TC_DFloat_1 := Derived_Float_1'Machine(TC_DFloat_1); + TC_DFloat_2 := Derived_Float_2'Machine(TC_DFloat_2); + + -- Checking for the closest machine number to each of the variables at + -- this point should produce the same values. + if Float'Machine(TC_Float) /= TC_Float or + Float_Subtype'Machine(TC_SFloat) /= TC_SFloat or + Derived_Float_1'Machine(TC_DFloat_1) /= TC_DFloat_1 or + Derived_Float_2'Machine(TC_DFloat_2) /= TC_DFloat_2 + then + Report.Failed("Incorrect result from the 'Machine attribute"); + end if; + + + -- New Model-Oriented Attributes. + -- + -- Check the S'Model_Small attribute. + + if Not_Equal + (Float'Model_Small, + Float(Float'Machine_Radix)**(Float'Model_Emin-1), + TC_Tolerance) + then + Report.Failed("Incorrect result from the 'Model_Small attribute"); + end if; + + + Report.Result; + +end CXA5015; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa5a01.a b/gcc/testsuite/ada/acats/tests/cxa/cxa5a01.a new file mode 100644 index 000000000..12db5e7e1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa5a01.a @@ -0,0 +1,338 @@ +-- CXA5A01.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 functions Sin and Sinh provide correct results. +-- +-- TEST DESCRIPTION: +-- This test examines both the version of Sin and Sinh resulting from +-- the instantiation of the Ada.Numerics.Generic_Elementary_Functions +-- with a type derived from type Float, as well as the preinstantiated +-- version of this package for type Float. +-- Prescribed results, as well as instances prescribed to raise +-- exceptions, are examined in the test cases. In addition, +-- certain evaluations are performed where the actual function result +-- is compared with the expected result (within an epsilon range of +-- accuracy). +-- +-- TEST FILES: +-- The following files comprise this test: +-- +-- FXA5A00.A (foundation code) +-- CXA5A01.A +-- +-- +-- CHANGE HISTORY: +-- 06 Mar 95 SAIC Initial prerelease version. +-- 13 Jun 95 SAIC Incorporated use of Dont_Optimize procedure, and +-- use of Result_Within_Range function overloaded for +-- FXA5A00.New_Float_Type. +-- 26 Jun 98 EDS Protected exception tests by first testing +-- for 'Machine_Overflows +--! + +with Ada.Numerics.Elementary_Functions; +with Ada.Numerics.Generic_Elementary_Functions; +with FXA5A00; +with Report; + +procedure CXA5A01 is +begin + + Report.Test ("CXA5A01", "Check that the functions Sin and Sinh provide " & + "correct results"); + + Test_Block: + declare + + use Ada.Numerics; + use FXA5A00; + + package GEF is new Ada.Numerics.Generic_Elementary_Functions(New_Float); + package EF renames Ada.Numerics.Elementary_Functions; + + The_Result : Float; + New_Float_Result : New_Float; + + procedure Dont_Optimize_Float is new Dont_Optimize(Float); + procedure Dont_Optimize_New_Float is new Dont_Optimize(New_Float); + + begin + + -- Testing of Sin Function, both instantiated and pre-instantiated + -- version. + + -- Check that no exception occurs on computing the Sin with very + -- large (positive and negative) input values. + + begin + New_Float_Result := GEF.Sin (New_Float(FXA5A00.Large)); + Dont_Optimize_New_Float(New_Float_Result, 1); + exception + when others => + Report.Failed("Unexpected exception on GEF.Sin with large " & + "positive value"); + end; + + begin + The_Result := EF.Sin (FXA5A00.Minus_Large); + Dont_Optimize_Float(The_Result, 2); + exception + when others => + Report.Failed("Unexpected exception on GEF.Sin with large " & + "negative value"); + end; + + + -- Test of Sin for prescribed result at zero. + + if GEF.Sin (0.0) /= 0.0 or + EF.Sin (0.0) /= 0.0 + then + Report.Failed("Incorrect value returned from Sin(0.0)"); + end if; + + + -- Test of Sin with expected result value between 0.0 and 1.0. + + if not (GEF.Sin (Ada.Numerics.Pi/4.0) < 1.0) or + not ( EF.Sin (Ada.Numerics.Pi/4.0) < 1.0) or + not FXA5A00.Result_Within_Range(GEF.Sin(0.35), 0.343, 0.001) or + not FXA5A00.Result_Within_Range( EF.Sin(1.18), 0.924, 0.001) + then + Report.Failed("Incorrect value returned from Sin function when " & + "the expected result is between 0.0 and 1.0"); + end if; + + + -- Test of Sin with expected result value between -1.0 and 0.0. + + if not (GEF.Sin (-Ada.Numerics.Pi/4.0) > -1.0) or + not ( EF.Sin (-Ada.Numerics.Pi/4.0) > -1.0) or + not FXA5A00.Result_Within_Range(GEF.Sin(-0.24), -0.238, 0.001) or + not FXA5A00.Result_Within_Range( EF.Sin(-1.00), -0.841, 0.001) + then + Report.Failed("Incorrect value returned from Sin function when " & + "the expected result is between -1.0 and 0.0"); + end if; + + + -- Testing of the Sin function with Cycle parameter. + + -- Check that Argument_Error is raised when the value of the Cycle + -- parameter is zero. + + begin + New_Float_Result := GEF.Sin (X => 1.0, Cycle => 0.0); + Report.Failed("Argument_Error not raised by GEF.Sin function " & + "when the Cycle parameter is zero"); + Dont_Optimize_New_Float(New_Float_Result, 3); + exception + when Ada.Numerics.Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by GEF.Sin function " & + "when the Cycle parameter is zero"); + end; + + begin + The_Result := EF.Sin (X => 0.34, Cycle => 0.0); + Report.Failed("Argument_Error not raised by EF.Sin function when " & + "the Cycle parameter is zero"); + Dont_Optimize_Float(The_Result, 4); + exception + when Ada.Numerics.Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by EF.Sin function " & + "when the Cycle parameter is zero"); + end; + + -- Check that Argument_Error is raised when the value of the Cycle + -- parameter is negative. + + begin + New_Float_Result := GEF.Sin (X => 0.45, Cycle => -1.0); + Report.Failed("Argument_Error not raised by GEF.Sin function " & + "when the Cycle parameter is negative"); + Dont_Optimize_New_Float(New_Float_Result, 5); + exception + when Ada.Numerics.Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by GEF.Sin function " & + "when the Cycle parameter is negative"); + end; + + begin + The_Result := EF.Sin (X => 0.10, Cycle => -4.0); + Report.Failed("Argument_Error not raised by EF.Sin function when " & + "the Cycle parameter is negative"); + Dont_Optimize_Float(The_Result, 6); + exception + when Ada.Numerics.Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by EF.Sin function " & + "when the Cycle parameter is negative"); + end; + + + -- Check that no exception occurs on computing the Sin with very + -- large (positive and negative) input values and Cycle parameter. + + begin + New_Float_Result := GEF.Sin (New_Float(FXA5A00.Large), 360.0); + Dont_Optimize_New_Float(New_Float_Result, 7); + exception + when others => + Report.Failed("Unexpected exception on GEF.Sin with large " & + "positive value and Cycle parameter"); + end; + + begin + The_Result := EF.Sin (FXA5A00.Minus_Large, 720.0); + Dont_Optimize_Float(The_Result, 8); + exception + when others => + Report.Failed("Unexpected exception on EF.Sin with large " & + "negative value and Cycle parameter"); + end; + + + -- Test of Sin with Cycle parameter for prescribed result at zero. + + if GEF.Sin (0.0, 360.0) /= 0.0 or + EF.Sin (0.0, 180.0) /= 0.0 + then + Report.Failed("Incorrect value returned from Sin function with " & + "cycle parameter for a zero input parameter value"); + end if; + + + -- Tests of Sin function with Cycle parameter for prescribed results. + + if GEF.Sin(0.0, 360.0) /= 0.0 or + EF.Sin(180.0, 360.0) /= 0.0 or + GEF.Sin(90.0, 360.0) /= 1.0 or + EF.Sin(450.0, 360.0) /= 1.0 or + GEF.Sin(270.0, 360.0) /= -1.0 or + EF.Sin(630.0, 360.0) /= -1.0 + then + Report.Failed("Incorrect result from the Sin function with " & + "various cycle values for prescribed results"); + end if; + + + -- Testing of Sinh Function, both instantiated and pre-instantiated + -- version. + + -- Test for Constraint_Error on parameter with large positive magnitude. + + begin + + if New_Float'Machine_Overflows then + New_Float_Result := GEF.Sinh (New_Float(FXA5A00.Large)); + Report.Failed("Constraint_Error not raised when the GEF.Sinh " & + "function is provided a parameter with a large " & + "positive value"); + Dont_Optimize_New_Float(New_Float_Result, 9); + end if; + + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Constraint_Error not raised when the GEF.Sinh " & + "function is provided a parameter with a large " & + "positive value"); + end; + + -- Test for Constraint_Error on parameter with large negative magnitude. + + begin + + if Float'Machine_Overflows then + The_Result := EF.Sinh (FXA5A00.Minus_Large); + Report.Failed("Constraint_Error not raised when the EF.Sinh " & + "function is provided a parameter with a " & + "large negative value"); + Dont_Optimize_Float(The_Result, 10); + end if; + + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Constraint_Error not raised when the EF.Sinh " & + "function is provided a parameter with a " & + "large negative value"); + end; + + + -- Test that no exception occurs when the Sinh function is provided a + -- very small positive or negative value. + + begin + New_Float_Result := GEF.Sinh (New_Float(FXA5A00.Small)); + Dont_Optimize_New_Float(New_Float_Result, 11); + exception + when others => + Report.Failed("Unexpected exception on GEF.Sinh with a very" & + "small positive value"); + end; + + begin + The_Result := EF.Sinh (-FXA5A00.Small); + Dont_Optimize_Float(The_Result, 12); + exception + when others => + Report.Failed("Unexpected exception on EF.Sinh with a very" & + "small negative value"); + end; + + + -- Test for prescribed 0.0 result of Function Sinh with 0.0 parameter. + + if GEF.Sinh (0.0) /= 0.0 or + EF.Sinh (0.0) /= 0.0 + then + Report.Failed("Incorrect value returned from Sinh(0.0)"); + end if; + + + -- Test of Sinh function with various input parameters. + + if not FXA5A00.Result_Within_Range(GEF.Sinh(0.01), 0.010, 0.001) or + not FXA5A00.Result_Within_Range( EF.Sinh(0.61), 0.649, 0.001) or + not FXA5A00.Result_Within_Range(GEF.Sinh(1.70), 2.65, 0.01) or + not FXA5A00.Result_Within_Range( EF.Sinh(3.15), 11.65, 0.01) + then + Report.Failed("Incorrect result returned from Sinh function " & + "with various input parameters"); + end if; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + +end CXA5A01; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa5a02.a b/gcc/testsuite/ada/acats/tests/cxa/cxa5a02.a new file mode 100644 index 000000000..9e6c575dd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa5a02.a @@ -0,0 +1,328 @@ +-- CXA5A02.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 functions Cos and Cosh provide correct results. +-- +-- TEST DESCRIPTION: +-- This test examines both the version of Cos and Cosh resulting from +-- the instantiation of the Ada.Numerics.Generic_Elementary_Functions +-- with type derived from type Float, as well as the pre-instantiated +-- version of this package for type Float. +-- Prescribed results, including instances prescribed to raise +-- exceptions, are examined in the test cases. In addition, +-- certain evaluations are performed where the actual function result +-- is compared with the expected result (within an epsilon range of +-- accuracy). +-- +-- TEST FILES: +-- The following files comprise this test: +-- +-- FXA5A00.A (foundation code) +-- CXA5A02.A +-- +-- +-- CHANGE HISTORY: +-- 09 Mar 95 SAIC Initial prerelease version. +-- 03 Apr 95 SAIC Removed reference to derived type. +-- 13 Jun 95 SAIC Incorporated use of Dont_Optimize procedure, and +-- use of Result_Within_Range function overloaded for +-- FXA5A00.New_Float_Type. +-- 28 Feb 97 PWB.CTA Removed checks specifying Cycle => 2.0 * Pi +-- 26 Jun 98 EDS Protected exception checks by first testing +-- for 'Machine_Overflows. Removed code deleted +-- by comment. +-- CHANGE NOTE: +-- According to Ken Dritz, author of the Numerics Annex of the RM, +-- one should never specify the cycle 2.0*Pi for the trigonometric +-- functions. In particular, if the machine number for the first +-- argument is not an exact multiple of the machine number for the +-- explicit cycle, then the specified exact results cannot be +-- reasonably expected. The affected checks have been deleted. +--! + +with Ada.Numerics.Elementary_Functions; +with Ada.Numerics.Generic_Elementary_Functions; +with FXA5A00; +with Report; + +procedure CXA5A02 is +begin + + Report.Test ("CXA5A02", "Check that the functions Cos and Cosh provide " & + "correct results"); + + Test_Block: + declare + + use Ada.Numerics; + use FXA5A00; + + package GEF is new Ada.Numerics.Generic_Elementary_Functions(New_Float); + package EF renames Ada.Numerics.Elementary_Functions; + + The_Result : Float; + New_Float_Result : New_Float; + + procedure Dont_Optimize_Float is new Dont_Optimize(Float); + procedure Dont_Optimize_New_Float is new Dont_Optimize(New_Float); + + begin + + -- Testing of Cos Function, both instantiated and pre-instantiated + -- version. + + -- Check that no exception occurs on computing the Cos with very + -- large (positive and negative) input values. + + begin + New_Float_Result := GEF.Cos (New_Float(FXA5A00.Large)); + Dont_Optimize_New_Float(New_Float_Result, 1); + exception + when others => + Report.Failed("Unexpected exception on GEF.Cos with large " & + "positive value"); + end; + + begin + The_Result := EF.Cos (FXA5A00.Minus_Large); + Dont_Optimize_Float(The_Result, 2); + exception + when others => + Report.Failed("Unexpected exception on GEF.Cos with large " & + "negative value"); + end; + + + -- Test of Cos for prescribed result at zero. + + if GEF.Cos (0.0) /= 1.0 or + EF.Cos (0.0) /= 1.0 + then + Report.Failed("Incorrect value returned from Cos(0.0)"); + end if; + + + -- Test of Cos with expected result value between 1.0 and -1.0. + + if not (Result_Within_Range( EF.Cos(Ada.Numerics.Pi/3.0), + 0.500, + 0.001) and + Result_Within_Range(GEF.Cos(0.6166), 0.816, 0.001) and + Result_Within_Range(GEF.Cos(0.1949), 0.981, 0.001) and + Result_Within_Range( EF.Cos(Ada.Numerics.Pi/2.0), + 0.00, + 0.001) and + Result_Within_Range( EF.Cos(2.0*Ada.Numerics.Pi/3.0), + -0.500, + 0.001) and + Result_Within_Range(GEF.Cos(New_Float(Ada.Numerics.Pi)), + -1.00, + 0.001)) + then + Report.Failed("Incorrect value returned from Cos function when " & + "the expected result is between 1.0 and -1.0"); + end if; + + + -- Testing of the Cos function with Cycle parameter. + + -- Check that Argument_Error is raised when the value of the Cycle + -- parameter is zero. + + begin + New_Float_Result := GEF.Cos (X => 1.0, Cycle => 0.0); + Report.Failed("Argument_Error not raised by GEF.Cos function " & + "when the Cycle parameter is zero"); + Dont_Optimize_New_Float(New_Float_Result, 3); + exception + when Ada.Numerics.Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by GEF.cos function " & + "when the Cycle parameter is zero"); + end; + + begin + The_Result := EF.Cos (X => 0.55, Cycle => 0.0); + Report.Failed("Argument_Error not raised by EF.Cos function when " & + "the Cycle parameter is zero"); + Dont_Optimize_Float(The_Result, 4); + exception + when Ada.Numerics.Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by EF.Cos function " & + "when the Cycle parameter is zero"); + end; + + -- Check that Argument_Error is raised when the value of the Cycle + -- parameter is negative. + + begin + New_Float_Result := GEF.Cos (X => 0.45, Cycle => -2.0*Pi); + Report.Failed("Argument_Error not raised by GEF.Cos function " & + "when the Cycle parameter is negative"); + Dont_Optimize_New_Float(New_Float_Result, 5); + exception + when Ada.Numerics.Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by GEF.Cos function " & + "when the Cycle parameter is negative"); + end; + + begin + The_Result := EF.Cos (X => 0.10, Cycle => -Pi/2.0); + Report.Failed("Argument_Error not raised by EF.Cos function when " & + "the Cycle parameter is negative"); + Dont_Optimize_Float(The_Result, 6); + exception + when Ada.Numerics.Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by EF.Cos function " & + "when the Cycle parameter is negative"); + end; + + -- Test of Cos with Cycle parameter for prescribed result at zero. + + if GEF.Cos (0.0, 360.0) /= 1.0 or + EF.Cos (0.0, 360.0) /= 1.0 + then + Report.Failed("Incorrect value returned from Cos function with " & + "cycle parameter for a zero input parameter value"); + end if; + + + -- Tests of Cos function with specified Cycle, using various input + -- parameter values for prescribed results. + + if GEF.Cos(0.0, 360.0) /= 1.0 or + EF.Cos(360.0, 360.0) /= 1.0 or + GEF.Cos(90.0, 360.0) /= 0.0 or + EF.Cos(270.0, 360.0) /= 0.0 or + GEF.Cos(180.0, 360.0) /= -1.0 or + EF.Cos(540.0, 360.0) /= -1.0 + then + Report.Failed("Incorrect result from the Cos function with " & + "specified cycle for prescribed results"); + end if; + + + + -- Testing of Cosh Function, both instantiated and pre-instantiated + -- version. + + -- Test for Constraint_Error on parameter with large positive magnitude. + + begin + + if New_Float'Machine_Overflows then + + New_Float_Result := GEF.Cosh (New_Float(FXA5A00.Large)); + Report.Failed("Constraint_Error not raised when the GEF.Cosh " & + "function is provided a parameter with a large " & + "positive value"); + Dont_Optimize_New_Float(New_Float_Result, 9); + end if; + + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Constraint_Error not raised when the GEF.Cosh " & + "function is provided a parameter with a large " & + "positive value"); + end; + + -- Test for Constraint_Error on parameter with large negative magnitude. + + begin + + if Float'Machine_Overflows then + The_Result := EF.Cosh (FXA5A00.Minus_Large); + Report.Failed("Constraint_Error not raised when the EF.Cosh " & + "function is provided a parameter with a " & + "large negative value"); + Dont_Optimize_Float(The_Result, 10); + end if; + + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Constraint_Error not raised when the EF.Cosh " & + "function is provided a parameter with a " & + "large negative value"); + end; + + + -- Test that no exception occurs when the Cosh function is provided a + -- very small positive or negative value. + + begin + New_Float_Result := GEF.Cosh (New_Float(FXA5A00.Small)); + Dont_Optimize_New_Float(New_Float_Result, 11); + exception + when others => + Report.Failed("Unexpected exception on GEF.Cosh with a very" & + "small positive value"); + end; + + begin + The_Result := EF.Cosh (-FXA5A00.Small); + Dont_Optimize_Float(The_Result, 12); + exception + when others => + Report.Failed("Unexpected exception on EF.Cosh with a very" & + "small negative value"); + end; + + + -- Test for prescribed 1.0 result of Function Cosh with 0.0 parameter. + + if GEF.Cosh (0.0) /= 1.0 or + EF.Cosh (0.0) /= 1.0 + then + Report.Failed("Incorrect value returned from Cosh(0.0)"); + end if; + + + -- Test of Cosh function with various input parameters. + + if not FXA5A00.Result_Within_Range(GEF.Cosh(0.24), 1.029, 0.001) or + not FXA5A00.Result_Within_Range( EF.Cosh(0.59), 1.179, 0.001) or + not FXA5A00.Result_Within_Range(GEF.Cosh(1.06), 1.616, 0.001) or + not FXA5A00.Result_Within_Range( EF.Cosh(1.50), 2.352, 0.001) or + not FXA5A00.Result_Within_Range(GEF.Cosh(1.84), 3.228, 0.001) or + not FXA5A00.Result_Within_Range( EF.Cosh(3.40), 14.99, 0.01) + then + Report.Failed("Incorrect result from Cosh function with " & + "various input parameters"); + end if; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + +end CXA5A02; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa5a03.a b/gcc/testsuite/ada/acats/tests/cxa/cxa5a03.a new file mode 100644 index 000000000..d99ba9bdc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa5a03.a @@ -0,0 +1,426 @@ +-- CXA5A03.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 functions Tan, Tanh, and Arctanh provide correct +-- results. +-- +-- TEST DESCRIPTION: +-- This test examines both the version of Tan, Tanh, and Arctanh +-- the instantiation of the Ada.Numerics.Generic_Elementary_Functions +-- with a type derived from type Float, as well as the preinstantiated +-- version of this package for type Float. +-- Prescribed results, including instances prescribed to raise +-- exceptions, are examined in the test cases. In addition, +-- certain evaluations are performed where the actual function result +-- is compared with the expected result (within an epsilon range of +-- accuracy). +-- +-- TEST FILES: +-- The following files comprise this test: +-- +-- FXA5A00.A (foundation code) +-- CXA5A03.A +-- +-- +-- CHANGE HISTORY: +-- 14 Mar 95 SAIC Initial prerelease version. +-- 06 Apr 95 SAIC Corrected errors in context clause references +-- and usage of Cycle parameter. +-- 13 Jun 95 SAIC Incorporated use of Dont_Optimize procedure, and +-- use of Result_Within_Range function overloaded for +-- FXA5A00.New_Float_Type. +-- 29 Jun 98 EDS Protected exception tests by first testing +-- for 'Machine_Overflows +-- +--! + +with Ada.Numerics.Elementary_Functions; +with Ada.Numerics.Generic_Elementary_Functions; +with FXA5A00; +with Report; + +procedure CXA5A03 is +begin + + Report.Test ("CXA5A03", "Check that the functions Tan, Tanh, and " & + "Arctanh provide correct results"); + + Test_Block: + declare + + use Ada.Numerics; + use FXA5A00; + + package GEF is new Ada.Numerics.Generic_Elementary_Functions(New_Float); + package EF renames Ada.Numerics.Elementary_Functions; + + The_Result : Float; + New_Float_Result : New_Float; + + procedure Dont_Optimize_Float is new Dont_Optimize(Float); + procedure Dont_Optimize_New_Float is new Dont_Optimize(New_Float); + + begin + + -- Testing of Tan Function, both instantiated and pre-instantiated + -- version. + + -- Check that no exception occurs on computing the Tan with very + -- large (positive and negative) input values. + + begin + New_Float_Result := GEF.Tan (New_Float(FXA5A00.Large)); + Dont_Optimize_New_Float(New_Float_Result, 1); + exception + when others => + Report.Failed("Unexpected exception on GEF.Tan with large " & + "positive value"); + end; + + begin + The_Result := EF.Tan (FXA5A00.Minus_Large); + Dont_Optimize_Float(The_Result, 2); + exception + when others => + Report.Failed("Unexpected exception on EF.Tan with large " & + "negative value"); + end; + + + -- Check that no exception occurs on computing the Tan with very + -- small (positive and negative) input values. + + begin + New_Float_Result := GEF.Tan (New_Float(FXA5A00.Small)); + Dont_Optimize_New_Float(New_Float_Result, 3); + exception + when others => + Report.Failed("Unexpected exception on GEF.Tan with small " & + "positive value"); + end; + + begin + The_Result := EF.Tan (-FXA5A00.Small); + Dont_Optimize_Float(The_Result, 4); + exception + when others => + Report.Failed("Unexpected exception on EF.Tan with small " & + "negative value"); + end; + + + -- Check prescribed result from Tan function. When the parameter X + -- has the value zero, the Tan function yields a result of zero. + + if GEF.Tan(0.0) /= 0.0 or + EF.Tan(0.0) /= 0.0 + then + Report.Failed("Incorrect result from Tan function with zero " & + "value input parameter"); + end if; + + + -- Check the results of the Tan function with various input parameters. + + if not (Result_Within_Range(GEF.Tan(0.7854), 1.0, 0.001) and + Result_Within_Range(GEF.Tan(0.8436), 1.124, 0.001) and + Result_Within_Range( EF.Tan(Pi), 0.0, 0.001) and + Result_Within_Range( EF.Tan(-Pi), 0.0, 0.001) and + Result_Within_Range(GEF.Tan(0.5381), 0.597, 0.001) and + Result_Within_Range( EF.Tan(0.1978), 0.200, 0.001)) + then + Report.Failed("Incorrect result from Tan function with various " & + "input parameters"); + end if; + + + -- Testing of Tan function with cycle parameter. + + -- Check that Constraint_Error is raised by the Tan function with + -- specified cycle, when the value of the parameter X is an odd + -- multiple of the quarter cycle. + + if New_Float'Machine_Overflows = True then + begin + New_Float_Result := GEF.Tan(270.0, 360.0); + Report.Failed("Constraint_Error not raised by GEF.Tan on odd " & + "multiple of the quarter cycle"); + Dont_Optimize_New_Float(New_Float_Result, 5); + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by GEF.Tan on odd " & + "multiple of the quarter cycle"); + end; + end if; + + -- Check that the exception Numerics.Argument_Error is raised, when + -- the value of the parameter Cycle is zero or negative. + + begin + New_Float_Result := GEF.Tan(X => 1.0, Cycle => -360.0); + Report.Failed("Argument_Error not raised by GEF.Tan when Cycle " & + "parameter has negative value"); + Dont_Optimize_New_Float(New_Float_Result, 6); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by GEF.Tan when Cycle " & + "parameter has negative value"); + end; + + begin + The_Result := EF.Tan(1.0, Cycle => 0.0); + Report.Failed("Argument_Error not raised by GEF.Tan when Cycle " & + "parameter has a zero value"); + Dont_Optimize_Float(The_Result, 7); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by EF.Tan when Cycle " & + "parameter has a zero value"); + end; + + + -- Check that no exception occurs on computing the Tan with very + -- large (positive and negative) input values. + + begin + New_Float_Result := GEF.Tan (New_Float(FXA5A00.Large), 360.0); + Dont_Optimize_New_Float(New_Float_Result, 8); + exception + when others => + Report.Failed("Unexpected exception on GEF.Tan with large " & + "positive value"); + end; + + begin + The_Result := EF.Tan (FXA5A00.Minus_Large, Cycle => 360.0); + Dont_Optimize_Float(The_Result, 9); + exception + when others => + Report.Failed("Unexpected exception on EF.Tan with large " & + "negative value"); + end; + + + -- Check prescribed result from Tan function with Cycle parameter. + + if GEF.Tan(0.0, 360.0) /= 0.0 or + EF.Tan(0.0, Cycle => 360.0) /= 0.0 + then + Report.Failed("Incorrect result from Tan function with cycle " & + "parameter, using a zero value input parameter"); + end if; + + + -- Check the Tan function, with specified Cycle parameter, with a + -- variety of input parameters. + + if not Result_Within_Range(GEF.Tan(30.0, 360.0), 0.577, 0.001) or + not Result_Within_Range( EF.Tan(57.0, 360.0), 1.540, 0.001) or + not Result_Within_Range(GEF.Tan(115.0, 360.0), -2.145, 0.001) or + not Result_Within_Range( EF.Tan(299.0, 360.0), -1.804, 0.001) or + not Result_Within_Range(GEF.Tan(390.0, 360.0), 0.577, 0.001) or + not Result_Within_Range( EF.Tan(520.0, 360.0), -0.364, 0.001) + then + Report.Failed("Incorrect result from the Tan function with " & + "cycle parameter, with various input parameter " & + "values"); + end if; + + + + -- Testing of Tanh Function, both instantiated and pre-instantiated + -- version. + + -- Check that no exception occurs on computing the Tan with very + -- large (positive and negative) input values. + + begin + New_Float_Result := GEF.Tanh (New_Float(FXA5A00.Large)); + Dont_Optimize_New_Float(New_Float_Result, 10); + exception + when others => + Report.Failed("Unexpected exception on GEF.Tanh with large " & + "positive value"); + end; + + begin + The_Result := EF.Tanh (FXA5A00.Minus_Large); + Dont_Optimize_Float(The_Result, 11); + exception + when others => + Report.Failed("Unexpected exception on EF.Tanh with large " & + "negative value"); + end; + + + -- Check for prescribed result of Tanh with zero value input parameter. + + if GEF.Tanh (0.0) /= 0.0 or + EF.Tanh (0.0) /= 0.0 + then + Report.Failed("Incorrect result from Tanh with zero parameter"); + end if; + + + -- Check the results of the Tanh function with various input + -- parameters. + + if not (FXA5A00.Result_Within_Range(GEF.Tanh(2.99), 0.995, 0.001) and + FXA5A00.Result_Within_Range(GEF.Tanh(0.130), 0.129, 0.001) and + FXA5A00.Result_Within_Range( EF.Tanh(Pi), 0.996, 0.001) and + FXA5A00.Result_Within_Range( EF.Tanh(-Pi), -0.996, 0.001) and + FXA5A00.Result_Within_Range(GEF.Tanh(0.60), 0.537, 0.001) and + FXA5A00.Result_Within_Range( EF.Tanh(1.04), 0.778, 0.001) and + FXA5A00.Result_Within_Range(GEF.Tanh(1.55), 0.914, 0.001) and + FXA5A00.Result_Within_Range( EF.Tanh(-2.14), -0.973, 0.001)) + then + Report.Failed("Incorrect result from Tanh function with various " & + "input parameters"); + end if; + + + + -- Testing of Arctanh Function, both instantiated and pre-instantiated + -- version. + + -- Check that Constraint_Error is raised by the Arctanh function + -- when the absolute value of the parameter X is one. + + if New_Float'Machine_Overflows = True then + begin + New_Float_Result := GEF.Arctanh(X => 1.0); + Report.Failed("Constraint_Error not raised by Function Arctanh " & + "when provided a parameter value of 1.0"); + Dont_Optimize_New_Float(New_Float_Result, 12); + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by Function Arctanh " + & "when provided a parameter value of 1.0"); + end; + end if; + + if Float'Machine_Overflows = True then + begin + The_Result := EF.Arctanh(-1.0); + Report.Failed("Constraint_Error not raised by Function Arctanh " & + "when provided a parameter value of -1.0"); + Dont_Optimize_Float(The_Result, 13); + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by Function Arctanh " + & "when provided a parameter value of -1.0"); + end; + end if; + + -- Check that Function Arctanh raises Argument_Error when the absolute + -- value of the parameter X exceeds one. + + begin + New_Float_Result := GEF.Arctanh(New_Float(FXA5A00.One_Plus_Delta)); + Report.Failed("Argument_Error not raised by Function Arctanh " & + "when provided a parameter value greater than 1.0"); + Dont_Optimize_New_Float(New_Float_Result, 14); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by Function Arctanh " & + "when provided a parameter value greater than 1.0"); + end; + + + begin + The_Result := EF.Arctanh(FXA5A00.Minus_One_Minus_Delta); + Report.Failed("Argument_Error not raised by Function Arctanh " & + "when provided a parameter value less than -1.0"); + Dont_Optimize_Float(The_Result, 15); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by Function Arctanh " & + "when provided a parameter value less than -1.0"); + end; + + + begin + New_Float_Result := GEF.Arctanh(New_Float(FXA5A00.Large)); + Report.Failed("Argument_Error not raised by Function Arctanh " & + "when provided a large positive parameter value"); + Dont_Optimize_New_Float(New_Float_Result, 16); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by Function Arctanh " & + "when provided a large positive parameter value"); + end; + + + begin + The_Result := EF.Arctanh(FXA5A00.Minus_Large); + Report.Failed("Argument_Error not raised by Function Arctanh " & + "when provided a large negative parameter value"); + Dont_Optimize_Float(The_Result, 17); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by Function Arctanh " & + "when provided a large negative parameter value"); + end; + + + -- Prescribed results for Function Arctanh with zero input value. + + if GEF.Arctanh(0.0) /= 0.0 or + EF.Arctanh(0.0) /= 0.0 + then + Report.Failed("Incorrect result from Function Arctanh with a " & + "parameter value of zero"); + end if; + + + -- Check the results of the Arctanh function with various input + -- parameters. + + if not (Result_Within_Range(GEF.Arctanh(0.15), 0.151, 0.001) and + Result_Within_Range( EF.Arctanh(0.44), 0.472, 0.001) and + Result_Within_Range(GEF.Arctanh(0.81), 1.127, 0.001) and + Result_Within_Range( EF.Arctanh(0.99), 2.647, 0.001)) + then + Report.Failed("Incorrect result from Arctanh function with " & + "various input parameters"); + end if; + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + +end CXA5A03; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa5a04.a b/gcc/testsuite/ada/acats/tests/cxa/cxa5a04.a new file mode 100644 index 000000000..9b590a23c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa5a04.a @@ -0,0 +1,434 @@ +-- CXA5A04.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 functions Cot, Coth, and Arccoth provide correct +-- results. +-- +-- TEST DESCRIPTION: +-- This test examines both the version of Cot, Coth, and Arccoth +-- the instantiation of the Ada.Numerics.Generic_Elementary_Functions +-- with a type derived from type Float, as well as the preinstantiated +-- version of this package for type Float. +-- Prescribed results, including instances prescribed to raise +-- exceptions, are examined in the test cases. In addition, +-- certain evaluations are performed where the actual function result +-- is compared with the expected result (within an epsilon range of +-- accuracy). +-- +-- TEST FILES: +-- The following files comprise this test: +-- +-- FXA5A00.A (foundation code) +-- CXA5A04.A +-- +-- +-- CHANGE HISTORY: +-- 15 Mar 95 SAIC Initial prerelease version. +-- 07 Apr 95 SAIC Corrected errors in context clause reference, +-- added trigonometric relationship checks. +-- 13 Jun 95 SAIC Incorporated use of Dont_Optimize procedure, and +-- use of Result_Within_Range function overloaded for +-- FXA5A00.New_Float_Type. +-- 18 Apr 96 SAIC Incorporated reviewer comments for ACVC 2.1. +-- 28 Feb 97 PWB.CTA Removed checks with explicit Cycle => 2.0*Pi +-- 29 Jun 98 EDS Protected exception tests by first testing +-- for 'Machine_Overflows +-- +-- CHANGE NOTE: +-- According to Ken Dritz, author of the Numerics Annex of the RM, +-- one should never specify the cycle 2.0*Pi for the trigonometric +-- functions. In particular, if the machine number for the first +-- argument is not an exact multiple of the machine number for the +-- explicit cycle, then the specified exact results cannot be +-- reasonably expected. The affected checks in this test have been +-- marked as comments, with the additional notation "pwb-math". +-- Phil Brashear +--! + +with Ada.Exceptions; +with Ada.Numerics.Elementary_Functions; +with Ada.Numerics.Generic_Elementary_Functions; +with FXA5A00; +with Report; + +procedure CXA5A04 is +begin + + Report.Test ("CXA5A04", "Check that the functions Cot, Coth, and " & + "Arccoth provide correct results"); + + Test_Block: + declare + + use Ada.Exceptions; + use Ada.Numerics; + use FXA5A00; + + package GEF is new Ada.Numerics.Generic_Elementary_Functions(New_Float); + package EF renames Ada.Numerics.Elementary_Functions; + + The_Result : Float; + New_Float_Result : New_Float; + + procedure Dont_Optimize_Float is new Dont_Optimize(Float); + procedure Dont_Optimize_New_Float is new Dont_Optimize(New_Float); + + begin + + -- Testing of Cot Function, both instantiated and pre-instantiated + -- version. + + -- Check that Constraint_Error is raised with the Cot function is + -- given a parameter input value of 0.0. + + if New_Float'Machine_Overflows = True then + begin + New_Float_Result := GEF.Cot (0.0); + Report.Failed("Constraint_Error not raised by Function Cot " & + "when provided a zero input parameter value"); + Dont_Optimize_New_Float(New_Float_Result, 1); + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by Function Cot " & + "when provided a zero input parameter value"); + end; + end if; + + -- Check that no exception occurs on computing the Cot with very + -- large (positive and negative) input values. + + begin + New_Float_Result := GEF.Cot (New_Float(FXA5A00.Large)); + Dont_Optimize_New_Float(New_Float_Result, 2); + exception + when others => + Report.Failed("Unexpected exception on GEF.Cot with large " & + "positive value"); + end; + + begin + The_Result := EF.Cot (FXA5A00.Minus_Large); + Dont_Optimize_Float(The_Result, 3); + exception + when others => + Report.Failed("Unexpected exception on EF.Cot with large " & + "negative value"); + end; + + + -- Check the results of the Cot function with various input parameters. + + if not (FXA5A00.Result_Within_Range(GEF.Cot(Pi/4.0), 1.0, 0.001) and + FXA5A00.Result_Within_Range( EF.Cot(Pi/2.0), 0.0, 0.001) and + FXA5A00.Result_Within_Range(GEF.Cot(3.0*Pi/4.0),-1.0, 0.001) and + FXA5A00.Result_Within_Range( EF.Cot(3.0*Pi/2.0), 0.0, 0.001)) + then + Report.Failed("Incorrect result from Cot function with various " & + "input parameters"); + end if; + + + -- Check the results of the Cot function against the results of + -- various trigonometric relationships. + + if not FXA5A00.Result_Within_Range(GEF.Cot(New_Float(Pi/4.0)), + 1.0/EF.Tan(Pi/4.0), + 0.001) or + not FXA5A00.Result_Within_Range(EF.Cot(Pi/4.0), + EF.Cos(Pi/4.0)/EF.Sin(Pi/4.0), + 0.001) or + not FXA5A00.Result_Within_Range(EF.Cot(EF.Arccot(Pi/4.0)), + Pi/4.0, + 0.001) + then + Report.Failed("Incorrect result from Cot function with respect " & + "to various trigonometric relationship expected " & + "results"); + end if; + + + -- Testing of Cot with Cycle parameter. + + -- Check that Argument_Error is raised by the Cot function when the + -- value of the Cycle parameter is zero or negative. + + begin + New_Float_Result := GEF.Cot (1.0, Cycle => 0.0); + Report.Failed("Argument_Error not raised by the Cot Function " & + "with a specified cycle value of 0.0"); + Dont_Optimize_New_Float(New_Float_Result, 4); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed + ("Unexpected exception raised by the Cot Function with " & + "a specified cycle value of 0.0"); + end; + + begin + The_Result := EF.Cot (X => 1.0, Cycle => -360.0); + Report.Failed("Argument_Error not raised by the Cot Function " & + "with a specified cycle value of -360.0"); + Dont_Optimize_Float(The_Result, 5); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed + ("Unexpected exception raised by the Cot Function with " & + "a specified cycle value of -360.0"); + end; + + + -- Check that Constraint_Error is raised by the Cot Function with + -- specified cycle, when the value of the parameter X is 0.0. + + if New_Float'Machine_Overflows = True then + begin + New_Float_Result := GEF.Cot (0.0, 360.0); + Report.Failed("Constraint_Error not raised by Function Cot " & + "with specified cycle, when value of parameter " & + "X is 0.0"); + Dont_Optimize_New_Float(New_Float_Result, 6); + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by Function Cot " & + "with specified cycle, when value of parameter " & + "X is 0.0"); + end; + end if; + + -- Check that Constraint_Error is raised by the Cot Function with + -- specified cycle, when the value of the parameter X is a multiple + -- of the half cycle. + + if New_Float'Machine_Overflows = True then + begin + New_Float_Result := GEF.Cot (180.0, 360.0); + Report.Failed("Constraint_Error not raised by Function Cot " & + "with specified cycle, when value of parameter " & + "X is a multiple of the half cycle (180.0, 360.0)"); + Dont_Optimize_New_Float(New_Float_Result, 7); + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by Function Cot " & + "with specified cycle, when value of parameter " & + "X is a multiple of the half cycle" & + " (180.0, 360.0)"); + end; + end if; + + if Float'Machine_Overflows = True then + begin + The_Result := EF.Cot (540.0, 360.0); + Report.Failed("Constraint_Error not raised by Function Cot " & + "with specified cycle, when value of parameter " & + "X is a multiple of the half cycle (540.0, 360.0)"); + Dont_Optimize_Float(The_Result, 8); + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by Function Cot " & + "with specified cycle, when value of parameter " & + "X is a multiple of the half cycle (540.0, 360.0)"); + end; + end if; + +--pwb-math -- Check that no exception occurs on computing the Cot with very +--pwb-math -- large (positive and negative) input values. +--pwb-math +--pwb-math begin +--pwb-math New_Float_Result := GEF.Cot (New_Float(FXA5A00.Large), 2.0*Pi); +--pwb-math Dont_Optimize_New_Float(New_Float_Result, 9); +--pwb-math exception +--pwb-math when others => +--pwb-math Report.Failed("Unexpected exception on GEF.Cot with large " & +--pwb-math "positive value"); +--pwb-math end; +--pwb-math +--pwb-math begin +--pwb-math The_Result := EF.Cot (FXA5A00.Minus_Large, Cycle => 2.0*Pi); +--pwb-math Dont_Optimize_Float(The_Result, 10); +--pwb-math exception +--pwb-math when others => +--pwb-math Report.Failed("Unexpected exception on EF.Cot with large " & +--pwb-math "negative value"); +--pwb-math end; +--pwb-math +--pwb-math +--pwb-math -- Check prescribed result from Cot function with Cycle parameter. +--pwb-math +--pwb-math if not FXA5A00.Result_Within_Range +--pwb-math (GEF.Cot(New_Float(FXA5A00.Half_Pi), 2.0*Pi), 0.0, 0.001) or +--pwb-math not FXA5A00.Result_Within_Range +--pwb-math (EF.Cot(3.0*Pi/2.0, Cycle => 2.0*Pi), 0.0, 0.001) +--pwb-math then +--pwb-math Report.Failed("Incorrect result from Cot function with cycle " & +--pwb-math "parameter, using a multiple of Pi/2 as the " & +--pwb-math "input parameter"); +--pwb-math end if; + + + -- Testing of Coth Function, both instantiated and pre-instantiated + -- version. + + -- Check that no exception occurs on computing the Coth with very + -- large (positive and negative) input values. + + begin + The_Result := EF.Coth (FXA5A00.Large); + if The_Result > 1.0 then + Report.Failed("Result of Coth function with large positive " & + "value greater than 1.0"); + end if; + exception + when others => + Report.Failed("Unexpected exception on EF.Coth with large " & + "positive value"); + end; + + begin + The_Result := EF.Coth (FXA5A00.Minus_Large); + if The_Result < -1.0 then + Report.Failed("Result of Coth function with large negative " & + "value less than -1.0"); + end if; + exception + when others => + Report.Failed("Unexpected exception on EF.Coth with large " & + "negative value"); + end; + + + -- Check that Constraint_Error is raised by the Coth function, when + -- the value of the parameter X is 0.0. + + if New_Float'Machine_Overflows = True then + begin + New_Float_Result := GEF.Coth (X => 0.0); + Report.Failed("Constraint_Error not raised by the Coth function " & + "when the value of parameter X is 0.0"); + Dont_Optimize_New_Float(New_Float_Result, 11); + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by the Coth " & + "function when the value of parameter X is 0.0"); + end; + end if; + + + -- Testing of Arccoth Function, both instantiated and pre-instantiated + -- version. + + -- Check that Constraint_Error is raised by the Arccoth function + -- when the absolute value of the parameter X is 1.0. + + if New_Float'Machine_Overflows = True then + begin + New_Float_Result := GEF.Arccoth (X => 1.0); + Report.Failed("Constraint_Error not raised by the Arccoth " & + "function when the value of parameter X is 1.0"); + Dont_Optimize_New_Float(New_Float_Result, 12); + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by the Arccoth " & + "function when the value of parameter X is 1.0"); + end; + end if; + + if Float'Machine_Overflows = True then + begin + The_Result := EF.Arccoth (-1.0); + Report.Failed("Constraint_Error not raised by the Arccoth " & + "function when the value of parameter X is -1.0"); + Dont_Optimize_Float(The_Result, 13); + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by the Arccoth " & + "function when the value of parameter X is -1.0"); + end; + end if; + + -- Check that Argument_Error is raised by the Arccoth function when + -- the absolute value of the parameter X is less than 1.0. + + begin + New_Float_Result := GEF.Arccoth (X => New_Float(One_Minus_Delta)); + Report.Failed("Argument_Error not raised by the Arccoth " & + "function with parameter value less than 1.0"); + Dont_Optimize_New_Float(New_Float_Result, 14); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by the Arccoth " & + "function with parameter value less than 1.0"); + end; + + begin + The_Result := EF.Arccoth (X => FXA5A00.Minus_One_Plus_Delta); + Report.Failed("Argument_Error not raised by the Arccoth function " & + "with parameter value between 0.0 and -1.0"); + Dont_Optimize_Float(The_Result, 15); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by the Arccoth " & + "function with parameter value between 0.0 " & + "and -1.0"); + end; + + + -- Check the results of the Arccoth function with various input + -- parameters. + + if not (Result_Within_Range(GEF.Arccoth(1.01), 2.652, 0.01) and + Result_Within_Range( EF.Arccoth(1.25), 1.099, 0.01) and + Result_Within_Range(GEF.Arccoth(1.56), 0.760, 0.001) and + Result_Within_Range( EF.Arccoth(1.97), 0.560, 0.001) and + Result_Within_Range(GEF.Arccoth(2.40), 0.444, 0.001) and + Result_Within_Range( EF.Arccoth(4.30), 0.237, 0.001) and + Result_Within_Range(GEF.Arccoth(5.80), 0.174, 0.001) and + Result_Within_Range( EF.Arccoth(7.00), 0.144, 0.001)) + then + Report.Failed("Incorrect result from Arccoth function with various " & + "input parameters"); + 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 CXA5A04; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa5a05.a b/gcc/testsuite/ada/acats/tests/cxa/cxa5a05.a new file mode 100644 index 000000000..b50da3a6a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa5a05.a @@ -0,0 +1,338 @@ +-- CXA5A05.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 functions Arcsin and Arcsinh provide correct +-- results. +-- +-- TEST DESCRIPTION: +-- This test examines both the version of Arcsin and Arcsinh +-- the instantiation of the Ada.Numerics.Generic_Elementary_Functions +-- with a type derived from type Float, as well as the preinstantiated +-- version of this package for type Float. +-- Prescribed results, including instances prescribed to raise +-- exceptions, are examined in the test cases. In addition, +-- certain evaluations are performed where the actual function result +-- is compared with the expected result (within an epsilon range of +-- accuracy). +-- +-- TEST FILES: +-- The following files comprise this test: +-- +-- FXA5A00.A (foundation code) +-- CXA5A05.A +-- +-- +-- CHANGE HISTORY: +-- 20 Mar 95 SAIC Initial prerelease version. +-- 06 Apr 95 SAIC Corrected errors in context clause reference and +-- use of Cycle parameter. +-- 13 Jun 95 SAIC Incorporated use of Dont_Optimize procedure, and +-- use of Result_Within_Range function overloaded for +-- FXA5A00.New_Float_Type. +-- 28 Feb 97 PWB.CTA Removed checks with explict Cycle => 2.0*Pi +-- +-- CHANGE NOTE: +-- According to Ken Dritz, author of the Numerics Annex of the RM, +-- one should never specify the cycle 2.0*Pi for the trigonometric +-- functions. In particular, if the machine number for the first +-- argument is not an exact multiple of the machine number for the +-- explicit cycle, then the specified exact results cannot be +-- reasonably expected. The affected checks in this test have been +-- marked as comments, with the additional notation "pwb-math". +-- Phil Brashear +--! + +with Ada.Numerics.Elementary_Functions; +with Ada.Numerics.Generic_Elementary_Functions; +with FXA5A00; +with Report; + +procedure CXA5A05 is +begin + + Report.Test ("CXA5A05", "Check that the functions Arcsin and Arcsinh " & + "provide correct results"); + + Test_Block: + declare + + use Ada.Numerics; + use FXA5A00; + + package GEF is new Ada.Numerics.Generic_Elementary_Functions(New_Float); + package EF renames Ada.Numerics.Elementary_Functions; + + The_Result : Float; + New_Float_Result : New_Float; + + procedure Dont_Optimize_Float is new Dont_Optimize(Float); + procedure Dont_Optimize_New_Float is new Dont_Optimize(New_Float); + + begin + + -- Testing of Function Arcsin, both instantiated and pre-instantiated + -- versions. + + -- Check that Argument_Error is raised by the Arcsin function when + -- the absolute value of the parameter X is greater than 1.0. + + begin + New_Float_Result := GEF.Arcsin(New_Float(FXA5A00.One_Plus_Delta)); + Report.Failed("Argument_Error not raised by Arcsin function " & + "when provided a parameter value larger than 1.0"); + Dont_Optimize_New_Float(New_Float_Result, 1); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by Arcsin function " & + "when provided a parameter value larger than 1.0"); + end; + + begin + The_Result := EF.Arcsin(FXA5A00.Minus_Large); + Report.Failed("Argument_Error not raised by Arcsin function " & + "when provided a large negative parameter value"); + Dont_Optimize_Float(The_Result, 2); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by Arcsin function " & + "when provided a large negative parameter value"); + end; + + + -- Check the prescribed result of function Arcsin with parameter 0.0. + + if GEF.Arcsin(X => 0.0) /= 0.0 or + EF.Arcsin(0.0) /= 0.0 + then + Report.Failed("Incorrect result from Function Arcsin when the " & + "value of the parameter X is 0.0"); + end if; + + + -- Check the results of the Arcsin function with various input + -- parameters. + + if not Result_Within_Range(GEF.Arcsin(1.0), 1.571, 0.001) or + not Result_Within_Range( EF.Arcsin(0.62), 0.669, 0.001) or + not Result_Within_Range(GEF.Arcsin(0.01), 0.010, 0.001) or + not Result_Within_Range( EF.Arcsin(-0.29), -0.294, 0.001) or + not Result_Within_Range(GEF.Arcsin(-0.50), -0.524, 0.001) or + not Result_Within_Range( EF.Arcsin(-1.0), -1.571, 0.001) + then + Report.Failed("Incorrect result from Function Arcsin with " & + "various input parameters"); + end if; + + + -- Testing of Function Arcsin with specified Cycle parameter. + +--pwb-math -- Check that Argument_Error is raised by the Arcsin function with +--pwb-math -- specified cycle, whenever the absolute value of the parameter X +--pwb-math -- is greater than 1.0. +--pwb-math +--pwb-math begin +--pwb-math New_Float_Result := GEF.Arcsin(New_Float(FXA5A00.Large), 2.0*Pi); +--pwb-math Report.Failed("Argument_Error not raised by Function Arcsin " & +--pwb-math "with specified cycle, when provided a large " & +--pwb-math "positive input parameter"); +--pwb-math Dont_Optimize_New_Float(New_Float_Result, 3); +--pwb-math exception +--pwb-math when Argument_Error => null; -- OK, expected exception. +--pwb-math when others => +--pwb-math Report.Failed("Unexpected exception raised by Function Arcsin " & +--pwb-math "with specified cycle, when provided a large " & +--pwb-math "positive input parameter"); +--pwb-math end; +--pwb-math +--pwb-math begin +--pwb-math The_Result := EF.Arcsin(FXA5A00.Minus_One_Minus_Delta, 2.0*Pi); +--pwb-math Report.Failed("Argument_Error not raised by Function Arcsin " & +--pwb-math "with specified cycle, when provided an input " & +--pwb-math "parameter less than -1.0"); +--pwb-math Dont_Optimize_Float(The_Result, 4); +--pwb-math exception +--pwb-math when Argument_Error => null; -- OK, expected exception. +--pwb-math when others => +--pwb-math Report.Failed("Unexpected exception raised by Function Arcsin " & +--pwb-math "with specified cycle, when provided an input " & +--pwb-math "parameter less than -1.0"); +--pwb-math end; +--pwb-math + -- Check that Argument_Error is raised by the Arcsin function with + -- specified cycle, whenever the Cycle parameter is zero or negative. + + begin + New_Float_Result := GEF.Arcsin(2.0, 0.0); + Report.Failed("Argument_Error not raised by Function Arcsin " & + "with specified cycle of 0.0"); + Dont_Optimize_New_Float(New_Float_Result, 5); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by Function Arcsin " & + "with specified cycle of 0.0"); + end; + + begin + The_Result := EF.Arcsin(2.0, -2.0*Pi); + Report.Failed("Argument_Error not raised by Function Arcsin " & + "with specified negative cycle parameter"); + Dont_Optimize_Float(The_Result, 6); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by Function Arcsin " & + "with specified negative cycle parameter"); + end; + + +--pwb-math -- Check the prescribed result of function Arcsin with specified Cycle +--pwb-math -- parameter, when the value of parameter X is 0.0. +--pwb-math +--pwb-math if GEF.Arcsin(X => 0.0, Cycle => 2.0*Pi) /= 0.0 or +--pwb-math EF.Arcsin(0.0, 2.0*Pi) /= 0.0 +--pwb-math then +--pwb-math Report.Failed("Incorrect result from Function Arcsin with " & +--pwb-math "specified Cycle parameter, when the value " & +--pwb-math "of parameter X is 0.0"); +--pwb-math end if; +--pwb-math +--pwb-math +--pwb-math -- Test of the Arcsin function with specified Cycle parameter with +--pwb-math -- various input parameters. +--pwb-math +--pwb-math if not FXA5A00.Result_Within_Range(GEF.Arcsin( 0.01, 2.0*Pi), +--pwb-math 0.010, +--pwb-math 0.001) or +--pwb-math not FXA5A00.Result_Within_Range( EF.Arcsin( 0.14, 2.0*Pi), +--pwb-math 0.141, +--pwb-math 0.001) or +--pwb-math not FXA5A00.Result_Within_Range(GEF.Arcsin( 0.37, 2.0*Pi), +--pwb-math 0.379, +--pwb-math 0.001) or +--pwb-math not FXA5A00.Result_Within_Range( EF.Arcsin( 0.55, 2.0*Pi), +--pwb-math 0.582, +--pwb-math 0.001) or +--pwb-math not FXA5A00.Result_Within_Range(GEF.Arcsin(-0.22, 2.0*Pi), +--pwb-math -0.222, +--pwb-math 0.001) or +--pwb-math not FXA5A00.Result_Within_Range( EF.Arcsin(-0.99, 2.0*Pi), +--pwb-math -1.43, +--pwb-math 0.01) or +--pwb-math not FXA5A00.Result_Within_Range( EF.Arcsin(1.0, 360.0), +--pwb-math 90.0, +--pwb-math 0.1) or +--pwb-math not FXA5A00.Result_Within_Range( EF.Arcsin(1.0, 100.0), +--pwb-math 25.0, +--pwb-math 0.1) +--pwb-math then +--pwb-math Report.Failed("Incorrect result from Arcsin with specified " & +--pwb-math "cycle parameter with various input parameters"); +--pwb-math end if; + + -- Testing of Arcsinh Function, both instantiated and pre-instantiated + -- version. + + -- Check that no exception occurs on computing the Arcsinh with very + -- large (positive and negative) input values. + + begin + New_Float_Result := GEF.Arcsinh(New_Float(FXA5A00.Large)); + Dont_Optimize_New_Float(New_Float_Result, 7); + exception + when others => + Report.Failed("Unexpected exception on Arcsinh with large " & + "positive value"); + end; + + begin + The_Result := EF.Arcsinh(FXA5A00.Minus_Large); + Dont_Optimize_Float(The_Result, 8); + exception + when others => + Report.Failed("Unexpected exception on Arcsinh with large " & + "negative value"); + end; + + + -- Check that no exception occurs on computing the Arcsinh with very + -- small (positive and negative) input values. + + begin + New_Float_Result := GEF.Arcsinh(New_Float(FXA5A00.Small)); + Dont_Optimize_New_Float(New_Float_Result, 9); + exception + when others => + Report.Failed("Unexpected exception on Arcsinh with small " & + "positive value"); + end; + + begin + The_Result := EF.Arcsinh(-FXA5A00.Small); + Dont_Optimize_Float(The_Result, 10); + exception + when others => + Report.Failed("Unexpected exception on Arcsinh with small " & + "negative value"); + end; + + + -- Check function Arcsinh for prescribed result with parameter 0.0. + + if GEF.Arcsinh(X => 0.0) /= 0.0 or + EF.Arcsinh(X => 0.0) /= 0.0 + then + Report.Failed("Incorrect result from Function Arcsinh when " & + "provided a 0.0 input parameter"); + end if; + + + -- Check the results of the Arcsinh function with various input + -- parameters. + + if not Result_Within_Range(GEF.Arcsinh(0.15), 0.149, 0.001) or + not Result_Within_Range( EF.Arcsinh(0.82), 0.748, 0.001) or + not Result_Within_Range(GEF.Arcsinh(1.44), 1.161, 0.001) or + not Result_Within_Range(GEF.Arcsinh(6.70), 2.601, 0.001) or + not Result_Within_Range( EF.Arcsinh(Pi), 1.862, 0.001) or + not Result_Within_Range( EF.Arcsinh(-Pi), -1.862, 0.001) or + not Result_Within_Range(GEF.Arcsinh(-1.0), -0.881, 0.001) or + not Result_Within_Range( EF.Arcsinh(-5.5), -2.406, 0.001) + then + Report.Failed("Incorrect result from Function Arcsin with " & + "various input parameters"); + end if; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + +end CXA5A05; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa5a06.a b/gcc/testsuite/ada/acats/tests/cxa/cxa5a06.a new file mode 100644 index 000000000..191a96d75 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa5a06.a @@ -0,0 +1,334 @@ +-- CXA5A06.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 functions Arccos and Arccosh provide correct +-- results. +-- +-- TEST DESCRIPTION: +-- This test examines both the version of Arccos and Arccosh +-- the instantiation of the Ada.Numerics.Generic_Elementary_Functions +-- with a type derived from type Float, as well as the preinstantiated +-- version of this package for type Float. +-- Prescribed results, including instances prescribed to raise +-- exceptions, are examined in the test cases. In addition, +-- certain evaluations are performed where the actual function result +-- is compared with the expected result (within an epsilon range of +-- accuracy). +-- +-- TEST FILES: +-- The following files comprise this test: +-- +-- FXA5A00.A (foundation code) +-- CXA5A06.A +-- +-- +-- CHANGE HISTORY: +-- 27 Mar 95 SAIC Initial prerelease version. +-- 13 Jun 95 SAIC Incorporated use of Dont_Optimize procedure, and +-- use of Result_Within_Range function overloaded for +-- FXA5A00.New_Float_Type. +-- 28 Feb 97 PWB.CTA Removed checks with explicit Cycle => 2.0*Pi +-- +-- CHANGE NOTE: +-- According to Ken Dritz, author of the Numerics Annex of the RM, +-- one should never specify the cycle 2.0*Pi for the trigonometric +-- functions. In particular, if the machine number for the first +-- argument is not an exact multiple of the machine number for the +-- explicit cycle, then the specified exact results cannot be +-- reasonably expected. The affected checks in this test have been +-- marked as comments, with the additional notation "pwb-math". +-- Phil Brashear +--! + +with Ada.Numerics.Elementary_Functions; +with Ada.Numerics.Generic_Elementary_Functions; +with FXA5A00; +with Report; + +procedure CXA5A06 is +begin + + Report.Test ("CXA5A06", "Check that the functions Arccos and Arccosh " & + "provide correct results"); + + Test_Block: + declare + + use Ada.Numerics; + use FXA5A00; + + package GEF is new Ada.Numerics.Generic_Elementary_Functions(New_Float); + package EF renames Ada.Numerics.Elementary_Functions; + + The_Result : Float; + New_Float_Result : New_Float; + + procedure Dont_Optimize_Float is new Dont_Optimize(Float); + procedure Dont_Optimize_New_Float is new Dont_Optimize(New_Float); + + begin + + -- Testing of Arccos Function, both instantiated and pre-instantiated + -- version. + + -- Check that Argument_Error is raised by the Arccos function when the + -- absolute value of the input parameter is greater than 1.0. + + begin + New_Float_Result := GEF.Arccos(New_Float(FXA5A00.One_Plus_Delta)); + Report.Failed("Argument_Error not raised by the Arccos function " & + "when the input parameter is greater than 1.0"); + Dont_Optimize_New_Float(New_Float_Result, 1); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by the Arccos " & + "function when the input parameter is greater " & + "than 1.0"); + end; + + begin + The_Result := EF.Arccos(-FXA5A00.Large); + Report.Failed("Argument_Error not raised by the Arccos function " & + "when the input parameter is a large negative value"); + Dont_Optimize_Float(The_Result, 2); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by the Arccos " & + "function when the input parameter is a " & + "large negative value"); + end; + + + -- Check the prescribed results of the Arccos function. + + if GEF.Arccos(X => 1.0) /= 0.0 or + EF.Arccos(1.0) /= 0.0 + then + Report.Failed("Incorrect result returned by the Arccos function " & + "when provided a parameter value of 0.0"); + end if; + + + -- Check the results of the Arccos function with various input + -- parameters. + + if not Result_Within_Range(GEF.Arccos(0.77), 0.692, 0.001) or + not Result_Within_Range( EF.Arccos(0.37), 1.19, 0.01) or + not Result_Within_Range(GEF.Arccos(0.0), Pi/2.0, 0.01) or + not Result_Within_Range( EF.Arccos(-0.11), 1.68, 0.01) or + not Result_Within_Range(GEF.Arccos(-0.67), 2.31, 0.01) or + not Result_Within_Range( EF.Arccos(-0.94), 2.79, 0.01) or + not Result_Within_Range(GEF.Arccos(-1.0), Pi, 0.01) + then + Report.Failed("Incorrect result returned from the Arccos " & + "function when provided a variety of input " & + "parameters"); + end if; + + + -- Testing of the Arccos function with specified Cycle parameter. + + -- Check that Argument_Error is raised by the Arccos function, with + -- specified Cycle parameter, when the absolute value of the input + -- parameter is greater than 1.0. + + begin +--pwb-math: Next line: Changed 2.0*Pi to 360.0 + New_Float_Result := GEF.Arccos(New_Float(Large), Cycle => 360.0); + Report.Failed("Argument_Error not raised by the Arccos function " & + "with specified Cycle parameter, when the input " & + "parameter is a large positive value"); + Dont_Optimize_New_Float(New_Float_Result, 3); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by the Arccos " & + "function with specified Cycle parameter, when " & + "the input parameter is a large positive value"); + end; + + begin +--pwb-math: Next line: Changed 2.0*Pi to 360.0 + The_Result := EF.Arccos(FXA5A00.Minus_One_Minus_Delta, 360.0); + Report.Failed("Argument_Error not raised by the Arccos function " & + "with specified Cycle parameter, when the input " & + "parameter is less than -1.0"); + Dont_Optimize_Float(The_Result, 4); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by the Arccos " & + "function with specified Cycle parameter, " & + "when the input parameter is less than -1.0"); + end; + + + -- Check that Argument_Error is raised by the Arccos function with + -- specified cycle when the value of the Cycle parameter is zero or + -- negative. + + begin + New_Float_Result := GEF.Arccos(X => 1.0, Cycle => 0.0 ); + Report.Failed("Argument_Error not raised by the Arccos function " & + "with specified Cycle parameter, when the Cycle " & + "parameter is 0.0"); + Dont_Optimize_New_Float(New_Float_Result, 5); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by the Arccos " & + "function with specified Cycle parameter, when " & + "the Cycle parameter is 0.0"); + end; + + begin + The_Result := EF.Arccos(1.0, Cycle => -2.0*Pi); + Report.Failed("Argument_Error not raised by the Arccos function " & + "with specified Cycle parameter, when the Cycle " & + "parameter is negative"); + Dont_Optimize_Float(The_Result, 6); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by the Arccos " & + "function with specified Cycle parameter, when " & + "the Cycle parameter is negative"); + end; + + + -- Check the prescribed result of the Arccos function with specified + -- Cycle parameter. + +--pwb-math: Next two lines: Changed 2.0*Pi to 360.0 + if GEF.Arccos(X => 1.0, Cycle => 360.0) /= 0.0 or + EF.Arccos(1.0, 360.0) /= 0.0 + then + Report.Failed("Incorrect result from the Arccos function with " & + "specified Cycle parameter, when the input " & + "parameter value is 1.0"); + end if; + + + -- Check the results of the Arccos function, with specified Cycle + -- parameter, with various input parameters. + + if --pwb-math not Result_Within_Range(GEF.Arccos( 0.04, 2.0*Pi), 1.53, 0.01) or +--pwb-math not Result_Within_Range( EF.Arccos( 0.14, 2.0*Pi), 1.43, 0.01) or +--pwb-math not Result_Within_Range(GEF.Arccos( 0.57, 2.0*Pi), 0.96, 0.01) or +--pwb-math not Result_Within_Range( EF.Arccos( 0.99, 2.0*Pi), 0.14, 0.01) or + not Result_Within_Range(GEF.Arccos(-1.0, 360.0), 180.0, 0.1) or + not Result_Within_Range(GEF.Arccos(-1.0, 100.0), 50.0, 0.1) or + not Result_Within_Range(GEF.Arccos( 0.0, 360.0), 90.0, 0.1) or + not Result_Within_Range(GEF.Arccos( 0.0, 100.0), 25.0, 0.1) + then + Report.Failed("Incorrect result returned from the Arccos " & + "function with specified Cycle parameter, " & + "when provided a variety of input parameters"); + end if; + + + + -- Testing of Arccosh Function, both instantiated and pre-instantiated + -- version. + + -- Check that Argument_Error is raised by the Arccosh function when + -- the value of the parameter X is less than 1.0. + + begin + New_Float_Result := GEF.Arccosh(New_Float(FXA5A00.One_Minus_Delta)); + Report.Failed("Argument_Error not raised by the Arccosh function " & + "when the parameter value is less than 1.0"); + Dont_Optimize_New_Float(New_Float_Result, 7); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by the Arccosh " & + "function when given a parameter value less " & + "than 1.0"); + end; + + begin + The_Result := EF.Arccosh(0.0); + Report.Failed("Argument_Error not raised by the Arccosh function " & + "when the parameter value is 0.0"); + Dont_Optimize_Float(The_Result, 8); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by the Arccosh " & + "function when given a parameter value of 0.0"); + end; + + begin + New_Float_Result := GEF.Arccosh(New_Float(-FXA5A00.Large)); + Report.Failed("Argument_Error not raised by the Arccosh function " & + "when the large negative parameter value"); + Dont_Optimize_New_Float(New_Float_Result, 9); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by the Arccosh " & + "function when given a large negative parameter " & + "value"); + end; + + + -- Check the prescribed results of the Arccosh function. + + if GEF.Arccosh(X => 1.0) /= 0.0 or + EF.Arccosh(1.0) /= 0.0 + then + Report.Failed("Incorrect result returned by the Arccosh " & + "function when provided a parameter value of 0.0"); + end if; + + + -- Check the results of the Arccosh function with various input + -- parameters. + + if not Result_Within_Range(GEF.Arccosh(1.03), 0.244, 0.001) or + not Result_Within_Range( EF.Arccosh(1.28), 0.732, 0.001) or + not Result_Within_Range(GEF.Arccosh(1.50), 0.962, 0.001) or + not Result_Within_Range( EF.Arccosh(1.77), 1.17, 0.01) or + not Result_Within_Range(GEF.Arccosh(2.00), 1.32, 0.01) or + not Result_Within_Range( EF.Arccosh(4.30), 2.14, 0.01) or + not Result_Within_Range(GEF.Arccosh(6.90), 2.62, 0.01) + then + Report.Failed("Incorrect result returned from the Arccosh " & + "function when provided a variety of input " & + "parameters"); + end if; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + +end CXA5A06; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa5a07.a b/gcc/testsuite/ada/acats/tests/cxa/cxa5a07.a new file mode 100644 index 000000000..179d54c44 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa5a07.a @@ -0,0 +1,413 @@ +-- CXA5A07.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 Arctan provides correct results. +-- +-- TEST DESCRIPTION: +-- This test examines both the version of Arctan resulting from the +-- instantiation of the Ada.Numerics.Generic_Elementary_Functions with +-- a type derived from type Float, as well as the preinstantiated +-- version of this package for type Float. +-- Prescribed results, including instances prescribed to raise +-- exceptions, are examined in the test cases. In addition, +-- certain evaluations are performed where the actual function result +-- is compared with the expected result (within an epsilon range of +-- accuracy). +-- +-- TEST FILES: +-- The following files comprise this test: +-- +-- FXA5A00.A (foundation code) +-- CXA5A07.A +-- +-- +-- CHANGE HISTORY: +-- 04 Apr 95 SAIC Initial prerelease version. +-- 13 Jun 95 SAIC Incorporated use of Dont_Optimize procedure, and +-- use of Result_Within_Range function overloaded for +-- FXA5A00.New_Float_Type. +-- 28 Feb 97 PWB.CTA Removed checks with explicit Cycle => 2.0*Pi +-- +-- CHANGE NOTE: +-- According to Ken Dritz, author of the Numerics Annex of the RM, +-- one should never specify the cycle 2.0*Pi for the trigonometric +-- functions. In particular, if the machine number for the first +-- argument is not an exact multiple of the machine number for the +-- explicit cycle, then the specified exact results cannot be +-- reasonably expected. The affected checks in this test have been +-- marked as comments, with the additional notation "pwb-math". +-- Phil Brashear +--! + +with Ada.Numerics.Elementary_Functions; +with Ada.Numerics.Generic_Elementary_Functions; +with FXA5A00; +with Report; + +procedure CXA5A07 is +begin + + Report.Test ("CXA5A07", "Check that the Arctan function provides " & + "correct results"); + + Test_Block: + declare + + use Ada.Numerics; + use FXA5A00; + + package GEF is new Ada.Numerics.Generic_Elementary_Functions(New_Float); + package EF renames Ada.Numerics.Elementary_Functions; + + Float_Result : Float; + New_Float_Result : New_Float; + + procedure Dont_Optimize_Float is new Dont_Optimize(Float); + procedure Dont_Optimize_New_Float is new Dont_Optimize(New_Float); + + begin + + -- Testing of Arctan Function, both instantiated and pre-instantiated + -- version. + + -- Check that Argument_Error is raised by the Arctan function when + -- provided parameter values of 0.0, 0.0. + + begin + New_Float_Result := GEF.Arctan(Y => 0.0, X => 0.0); + Report.Failed("Argument_Error not raised when the Arctan " & + "function is provided input of 0.0, 0.0"); + Dont_Optimize_New_Float(New_Float_Result, 1); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by the Arctan " & + "function when provided 0.0, 0.0 input parameters"); + end; + + + -- Check that no exception is raised by the Arctan function when + -- provided a large positive or negative Y parameter value, when + -- using the default value for parameter X. + + begin + Float_Result := EF.Arctan(Y => FXA5A00.Large); + Dont_Optimize_Float(Float_Result, 2); + exception + when others => + Report.Failed("Exception raised when the Arctan function is " & + "provided a large positive Y parameter value"); + end; + + begin + New_Float_Result := GEF.Arctan(Y => New_Float(-FXA5A00.Large)); + Dont_Optimize_New_Float(New_Float_Result, 3); + exception + when others => + Report.Failed("Exception raised when the Arctan function is " & + "provided a large negative Y parameter value"); + end; + + + -- Check that no exception is raised by the Arctan function when + -- provided a small positive or negative Y parameter value, when + -- using the default value for parameter X. + + begin + Float_Result := EF.Arctan(Y => FXA5A00.Small); + Dont_Optimize_Float(Float_Result, 4); + exception + when others => + Report.Failed("Exception raised when the Arctan function is " & + "provided a small positive Y parameter value"); + end; + + begin + New_Float_Result := GEF.Arctan(Y => New_Float(-FXA5A00.Small)); + Dont_Optimize_New_Float(New_Float_Result, 5); + exception + when others => + Report.Failed("Exception raised when the Arctan function is " & + "provided a small negative Y parameter value"); + end; + + + -- Check that no exception is raised by the Arctan function when + -- provided combinations of large and small positive or negative + -- parameter values for both Y and X input parameters. + + begin + Float_Result := EF.Arctan(Y => FXA5A00.Large, X => FXA5A00.Large); + Dont_Optimize_Float(Float_Result, 6); + exception + when others => + Report.Failed("Exception raised when the Arctan function is " & + "provided large positive X and Y parameter values"); + end; + + begin + New_Float_Result := GEF.Arctan(New_Float(-FXA5A00.Large), + X => New_Float(FXA5A00.Small)); + Dont_Optimize_New_Float(New_Float_Result, 7); + exception + when others => + Report.Failed("Exception raised when the Arctan function is " & + "provided a large negative Y parameter value " & + "and a small positive X parameter value"); + end; + + + begin + Float_Result := EF.Arctan(Y => FXA5A00.Small, X => FXA5A00.Large); + Dont_Optimize_Float(Float_Result, 8); + exception + when others => + Report.Failed("Exception raised when the Arctan function is " & + "provided a small positive Y parameter value " & + "and a large positive X parameter value"); + end; + + begin + New_Float_Result := GEF.Arctan(New_Float(-FXA5A00.Small), + New_Float(-FXA5A00.Large)); + Dont_Optimize_New_Float(New_Float_Result, 9); + exception + when others => + Report.Failed("Exception raised when the Arctan function is " & + "provided a small negative Y parameter value " & + "and a large negative parameter value"); + end; + + + -- Check that when the Arctan function is provided a Y parameter value + -- of 0.0 and a positive X parameter input value, the prescribed result + -- of zero is returned. + + if GEF.Arctan(Y => 0.0) /= 0.0 or -- Default X value + EF.Arctan(Y => 0.0, X => FXA5A00.Large) /= 0.0 or +--pwb-math: Next line: changed 2.0*Pi to 360.0 + GEF.Arctan(0.0, 360.0) /= 0.0 or + EF.Arctan(0.0, FXA5A00.Small) /= 0.0 + then + Report.Failed("Incorrect results from the Arctan function when " & + "provided a Y parameter value of 0.0 and various " & + "positive X parameter values"); + end if; + + + -- Check that the Arctan function provides correct results when provided + -- a variety of Y parameter values. + + if not FXA5A00.Result_Within_Range(EF.Arctan(Pi), 1.26, 0.01) or + not FXA5A00.Result_Within_Range(EF.Arctan(-Pi), -1.26, 0.01) or + not FXA5A00.Result_Within_Range(GEF.Arctan(1.0), 0.785, 0.001) or + not FXA5A00.Result_Within_Range(EF.Arctan(-1.0), -0.785, 0.001) or + not FXA5A00.Result_Within_Range(GEF.Arctan(0.25), 0.245, 0.001) or + not FXA5A00.Result_Within_Range(EF.Arctan(0.92), 0.744, 0.001) + then + Report.Failed("Incorrect results from the Arctan function when " & + "provided a variety of Y parameter values"); + end if; + + + + -- Check the results of the Arctan function with specified cycle + -- parameter. + + -- Check that the Arctan function with specified Cycle parameter + -- raises Argument_Error when the value of the Cycle parameter is zero + -- or negative. + + begin + Float_Result := EF.Arctan(Y => Pi, Cycle => 0.0); -- Default X value + Report.Failed("Argument_Error not raised by the Arctan function " & + "with default X parameter value, when the Cycle " & + "parameter is 0.0"); + Dont_Optimize_Float(Float_Result, 10); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by the Arctan " & + "function with default X parameter value, when " & + "provided a 0.0 cycle parameter value"); + end; + + begin + New_Float_Result := GEF.Arctan(Y => Pi, X => 1.0, Cycle => 0.0); + Report.Failed("Argument_Error not raised by the Arctan function " & + "when the Cycle parameter is 0.0"); + Dont_Optimize_New_Float(New_Float_Result, 11); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by the Arctan " & + "function when provided a 0.0 cycle parameter " & + "value"); + end; + + begin + Float_Result := EF.Arctan(Y => Pi, Cycle => -360.0); + Report.Failed("Argument_Error not raised by the Arctan function " & + "with a default X parameter value, when the Cycle " & + "parameter is -360.0"); + Dont_Optimize_Float(Float_Result, 12); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by the Arctan " & + "function with a default X parameter value, when " & + "provided a -360.0 cycle parameter value"); + end; + + begin + New_Float_Result := GEF.Arctan(Y => Pi, X => 1.0, Cycle => -Pi); + Report.Failed("Argument_Error not raised by the Arctan function " & + "when the Cycle parameter is -Pi"); + Dont_Optimize_New_Float(New_Float_Result, 13); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by the Arctan " & + "function when provided a -Pi cycle parameter " & + "value"); + end; + + + -- Check that no exception is raised by the Arctan function with + -- specified Cycle parameter, when provided large and small positive + -- or negative parameter values for both Y and X input parameters. + + begin + Float_Result := EF.Arctan(Y => -FXA5A00.Large, + X => -FXA5A00.Large, +--pwb-math: Next line: changed 2.0*Pi to 360.0 + Cycle => 360.0); + Dont_Optimize_Float(Float_Result, 14); + exception + when others => + Report.Failed("Exception raised when the Arctan function with " & + "specified Cycle parameter, when provided large " & + "negative X and Y parameter values"); + end; + + + begin + New_Float_Result := GEF.Arctan(New_Float(FXA5A00.Large), + X => New_Float(-FXA5A00.Small), +--pwb-math: Next line: changed 2.0*Pi to 360.0 + Cycle => 360.0); + Dont_Optimize_New_Float(New_Float_Result, 15); + exception + when others => + Report.Failed("Exception raised when the Arctan function with " & + "specified Cycle parameter, when provided large " & + "positive Y parameter value and a small negative " & + "X parameter value"); + end; + + + begin + Float_Result := EF.Arctan(Y => -FXA5A00.Small, + X => -FXA5A00.Large, +--pwb-math: Next line: changed 2.0*Pi to 360.0 + Cycle => 360.0); + Dont_Optimize_Float(Float_Result, 16); + exception + when others => + Report.Failed("Exception raised when the Arctan function with " & + "specified Cycle parameter, when provided large " & + "negative Y parameter value and a large negative " & + "X parameter value"); + end; + + begin + New_Float_Result := GEF.Arctan(New_Float(FXA5A00.Small), + New_Float(FXA5A00.Large), +--pwb-math: Next line: changed 2.0*Pi to 360.0 + 360.0); + Dont_Optimize_New_Float(New_Float_Result, 17); + exception + when others => + Report.Failed("Exception raised when the Arctan function with " & + "specified Cycle parameter, when provided a " & + "small negative Y parameter value and a large " & + "positive X parameter value"); + end; + + + -- Check that the Arctan function with specified Cycle parameter + -- provides correct results when provided a variety of Y parameter + -- input values. + +--pwb-math if not FXA5A00.Result_Within_Range(EF.Arctan(Pi, Cycle => 2.0*Pi), +--pwb-math 1.26, +--pwb-math 0.01) or +--pwb-math not FXA5A00.Result_Within_Range(EF.Arctan(-Pi, Cycle => 2.0*Pi), +--pwb-math -1.26, +--pwb-math 0.01) or +--pwb-math not FXA5A00.Result_Within_Range(GEF.Arctan(1.0, Cycle => 2.0*Pi), +--pwb-math 0.785, +--pwb-math 0.001) or +--pwb-math not FXA5A00.Result_Within_Range(EF.Arctan(-1.0, Cycle => 2.0*Pi), +--pwb-math -0.785, +--pwb-math 0.001) or +--pwb-math not FXA5A00.Result_Within_Range(GEF.Arctan(0.16, Cycle => 2.0*Pi), +--pwb-math 0.159, +--pwb-math 0.001) or +--pwb-math not FXA5A00.Result_Within_Range(EF.Arctan(1.0, Cycle => 360.0), +--pwb-math 45.0, +--pwb-math 0.1) or +--pwb-math not FXA5A00.Result_Within_Range(GEF.Arctan(1.0, Cycle => 100.0), +--pwb-math 12.5, +--pwb-math 0.1) + +--pwb-math Next 12 lines are replacements for 21 commented lines above + if not FXA5A00.Result_Within_Range(GEF.Arctan(1.0, Cycle => 2.0*180.0), + 45.0, + 0.001) or + not FXA5A00.Result_Within_Range(EF.Arctan(-1.0, Cycle => 2.0*180.0), + -45.0, + 0.001) or + not FXA5A00.Result_Within_Range(EF.Arctan(1.0, Cycle => 360.0), + 45.0, + 0.1) or + not FXA5A00.Result_Within_Range(GEF.Arctan(1.0, Cycle => 100.0), + 12.5, + 0.1) + then + Report.Failed("Incorrect results from the Arctan function with " & + "specified Cycle parameter when provided a variety " & + "of Y parameter values"); + end if; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + +end CXA5A07; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa5a08.a b/gcc/testsuite/ada/acats/tests/cxa/cxa5a08.a new file mode 100644 index 000000000..ae2b85a6d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa5a08.a @@ -0,0 +1,474 @@ +-- CXA5A08.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 Arccot provides correct results. +-- +-- TEST DESCRIPTION: +-- This test examines both the version of Arccot resulting from the +-- instantiation of the Ada.Numerics.Generic_Elementary_Functions +-- with a type derived from type Float, as well as the preinstantiated +-- version of this package for type Float. +-- Prescribed results, including instances prescribed to raise +-- exceptions, are examined in the test cases. In addition, +-- certain evaluations are performed where the actual function result +-- is compared with the expected result (within an epsilon range of +-- accuracy). +-- +-- TEST FILES: +-- The following files comprise this test: +-- +-- FXA5A00.A (foundation code) +-- CXA5A08.A +-- +-- +-- CHANGE HISTORY: +-- 06 Apr 95 SAIC Initial prerelease version. +-- 13 Jun 95 SAIC Incorporated use of Dont_Optimize procedure, and +-- use of Result_Within_Range function overloaded for +-- FXA5A00.New_Float_Type. +-- 18 Apr 96 SAIC Incorporated reviewer comments for ACVC 2.1. +-- 28 Feb 97 CTA.PWB Removed checks with explicit Cycle => 2.0*Pi +-- +-- CHANGE NOTE: +-- According to Ken Dritz, author of the Numerics Annex of the RM, +-- one should never specify the cycle 2.0*Pi for the trigonometric +-- functions. In particular, if the machine number for the first +-- argument is not an exact multiple of the machine number for the +-- explicit cycle, then the specified exact results cannot be +-- reasonably expected. The affected checks in this test have been +-- marked as comments, with the additional notation "pwb-math". +-- Phil Brashear +--! + +with Ada.Exceptions; +with Ada.Numerics.Elementary_Functions; +with Ada.Numerics.Generic_Elementary_Functions; +with FXA5A00; +with Report; + +procedure CXA5A08 is +begin + + Report.Test ("CXA5A08", "Check that the Arccot function provides " & + "correct results"); + + Test_Block: + declare + + use Ada.Exceptions; + use Ada.Numerics; + use FXA5A00; + + package GEF is new Ada.Numerics.Generic_Elementary_Functions(New_Float); + package EF renames Ada.Numerics.Elementary_Functions; + + Float_Result : Float; + Angle : Float; + New_Float_Result : New_Float; + New_Float_Angle : New_Float; + Incorrect_Inverse : Boolean := False; + + procedure Dont_Optimize_Float is new Dont_Optimize(Float); + procedure Dont_Optimize_New_Float is new Dont_Optimize(New_Float); + + begin + + -- Testing of Arccot Function, both instantiated and pre-instantiated + -- version. + + -- Check that Argument_Error is raised by the Arccot function when + -- provided parameter values of 0.0, 0.0. + + begin + New_Float_Result := GEF.Arccot(X => 0.0, Y => 0.0); + Report.Failed("Argument_Error not raised when the Arccot " & + "function is provided input of 0.0, 0.0"); + Dont_Optimize_New_Float(New_Float_Result, 1); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by the Arccot " & + "function when provided 0.0, 0.0 input parameters"); + end; + + + -- Check that no exception is raised by the Arccot function when + -- provided a large positive or negative X parameter value, when + -- using the default value for parameter Y. + + begin + Float_Result := EF.Arccot(X => FXA5A00.Large); + Dont_Optimize_Float(Float_Result, 2); + exception + when others => + Report.Failed("Exception raised when the Arccot function is " & + "provided a large positive X parameter value"); + end; + + begin + New_Float_Result := GEF.Arccot(X => New_Float(-FXA5A00.Large)); + Dont_Optimize_New_Float(New_Float_Result, 3); + exception + when others => + Report.Failed("Exception raised when the Arccot function is " & + "provided a large negative X parameter value"); + end; + + + -- Check that no exception is raised by the Arccot function when + -- provided a small positive or negative X parameter value, when + -- using the default value for parameter Y. + + begin + Float_Result := EF.Arccot(X => FXA5A00.Small); + Dont_Optimize_Float(Float_Result, 4); + exception + when others => + Report.Failed("Exception raised when the Arccot function is " & + "provided a small positive X parameter value"); + end; + + begin + New_Float_Result := GEF.Arccot(X => New_Float(-FXA5A00.Small)); + Dont_Optimize_New_Float(New_Float_Result, 5); + exception + when others => + Report.Failed("Exception raised when the Arccot function is " & + "provided a small negative X parameter value"); + end; + + + -- Check that no exception is raised by the Arccot function when + -- provided combinations of large and small positive or negative + -- parameter values for both X and Y input parameters. + + begin + Float_Result := EF.Arccot(X => FXA5A00.Large, Y => FXA5A00.Large); + Dont_Optimize_Float(Float_Result, 6); + exception + when others => + Report.Failed("Exception raised when the Arccot function is " & + "provided large positive X and Y parameter values"); + end; + + begin + New_Float_Result := GEF.Arccot(New_Float(-FXA5A00.Large), + Y => New_Float(FXA5A00.Small)); + Dont_Optimize_New_Float(New_Float_Result, 7); + exception + when others => + Report.Failed("Exception raised when the Arccot function is " & + "provided a large negative X parameter value " & + "and a small positive Y parameter value"); + end; + + + begin + Float_Result := EF.Arccot(X => FXA5A00.Small, Y => FXA5A00.Large); + Dont_Optimize_Float(Float_Result, 8); + exception + when others => + Report.Failed("Exception raised when the Arccot function is " & + "provided a small positive X parameter value " & + "and a large positive Y parameter value"); + end; + + begin + New_Float_Result := GEF.Arccot(New_Float(-FXA5A00.Small), + New_Float(-FXA5A00.Large)); + Dont_Optimize_New_Float(New_Float_Result, 9); + exception + when others => + Report.Failed("Exception raised when the Arccot function is " & + "provided a small negative X parameter value " & + "and a large negative Y parameter value"); + end; + + + -- Check that when the Arccot function is provided a Y parameter value + -- of 0.0 and a positive X parameter input value, the prescribed result + -- of zero is returned. + + if EF.Arccot(X => FXA5A00.Large, Y => 0.0) /= 0.0 or + GEF.Arccot(2.0*Pi, Y => 0.0) /= 0.0 or + EF.Arccot(FXA5A00.Small, 0.0) /= 0.0 or + EF.Arccot(X => FXA5A00.Large, Y => 0.0, Cycle => 360.0) /= 0.0 or + GEF.Arccot(2.0*Pi, Y => 0.0, Cycle => 360.0) /= 0.0 or + EF.Arccot(FXA5A00.Small, 0.0, Cycle => 360.0) /= 0.0 + then + Report.Failed("Incorrect results from the Arccot function when " & + "provided a Y parameter value of 0.0 and various " & + "positive X parameter values"); + end if; + + + -- Check that the Arccot function provides correct results when + -- provided a variety of X parameter values. + + if not Result_Within_Range( EF.Arccot( 1.0), Pi/4.0, 0.001) or + not Result_Within_Range(GEF.Arccot( 0.0), Pi/2.0, 0.001) or + not Result_Within_Range( EF.Arccot(-1.0), 3.0*Pi/4.0, 0.001) + then + Report.Failed("Incorrect results from the Arccot function when " & + "provided a variety of Y parameter values"); + end if; + + + -- Check the results of the Arccot function with specified cycle + -- parameter. + + -- Check that the Arccot function with specified Cycle parameter + -- raises Argument_Error when the value of the Cycle parameter is zero + -- or negative. + + begin + Float_Result := EF.Arccot(X => Pi, Cycle => 0.0); -- Default Y value + Report.Failed("Argument_Error not raised by the Arccot function " & + "with default Y parameter value, when the Cycle " & + "parameter is 0.0"); + Dont_Optimize_Float(Float_Result, 10); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by the Arccot " & + "function with default Y parameter value, when " & + "provided a 0.0 cycle parameter value"); + end; + + begin + New_Float_Result := GEF.Arccot(X => Pi, Y => 1.0, Cycle => 0.0); + Report.Failed("Argument_Error not raised by the Arccot function " & + "when the Cycle parameter is 0.0"); + Dont_Optimize_New_Float(New_Float_Result, 11); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by the Arccot " & + "function when provided a 0.0 cycle parameter " & + "value"); + end; + + begin + Float_Result := EF.Arccot(X => Pi, Cycle => -360.0); + Report.Failed("Argument_Error not raised by the Arccot function " & + "with a default Y parameter value, when the Cycle " & + "parameter is -360.0"); + Dont_Optimize_Float(Float_Result, 12); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by the Arccot " & + "function with a default Y parameter value, when " & + "provided a -360.0 cycle parameter value"); + end; + + begin + New_Float_Result := GEF.Arccot(X => Pi, Y => 1.0, Cycle => -Pi); + Report.Failed("Argument_Error not raised by the Arccot function " & + "when the Cycle parameter is -Pi"); + Dont_Optimize_New_Float(New_Float_Result, 13); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by the Arccot " & + "function when provided a -Pi cycle parameter " & + "value"); + end; + + + -- Check that no exception is raised by the Arccot function with + -- specified Cycle parameter, when provided large and small positive + -- or negative parameter values for both X and Y input parameters. + + begin + Float_Result := EF.Arccot(X => -FXA5A00.Large, + Y => -FXA5A00.Large, +--pwb-math Next line: changed 2.0*Pi to 360.0 + Cycle => 360.0); + Dont_Optimize_Float(Float_Result, 14); + exception + when others => + Report.Failed("Exception raised when the Arccot function with " & + "specified Cycle parameter, when provided large " & + "negative X and Y parameter values"); + end; + + + begin + New_Float_Result := GEF.Arccot(New_Float(FXA5A00.Large), + Y => New_Float(-FXA5A00.Small), +--pwb-math Next line: changed 2.0*Pi to 360.0 + Cycle => 360.0); + Dont_Optimize_New_Float(New_Float_Result, 15); + exception + when others => + Report.Failed("Exception raised when the Arccot function with " & + "specified Cycle parameter, when provided large " & + "positive X parameter value and a small negative " & + "Y parameter value"); + end; + + + begin + Float_Result := EF.Arccot(X => -FXA5A00.Small, + Y => -FXA5A00.Large, +--pwb-math Next line: changed 2.0*Pi to 360.0 + Cycle => 360.0); + Dont_Optimize_Float(Float_Result, 16); + exception + when others => + Report.Failed("Exception raised when the Arccot function with " & + "specified Cycle parameter, when provided small " & + "negative X parameter value and a large negative " & + "Y parameter value"); + end; + + begin + New_Float_Result := GEF.Arccot(New_Float(FXA5A00.Small), + New_Float(FXA5A00.Large), +--pwb-math Next line: changed 2.0*Pi to 360.0 + 360.0); + Dont_Optimize_New_Float(New_Float_Result, 17); + exception + when others => + Report.Failed("Exception raised when the Arccot function with " & + "specified Cycle parameter, when provided a " & + "small positive X parameter value and a large " & + "positive Y parameter value"); + end; + + + -- Check that the Arccot function with specified Cycle parameter + -- provides correct results when provided a variety of X parameter + -- input values. + + if not FXA5A00.Result_Within_Range(GEF.Arccot( 0.0, Cycle => 360.0), + 90.0, + 0.001) or + not FXA5A00.Result_Within_Range(EF.Arccot( 0.0, Cycle => 100.0), + 25.0, + 0.001) or + not FXA5A00.Result_Within_Range(GEF.Arccot( 1.0, Cycle => 360.0), + 45.0, + 0.001) or + not FXA5A00.Result_Within_Range(EF.Arccot( 1.0, Cycle => 100.0), + 12.5, + 0.001) or + not FXA5A00.Result_Within_Range(GEF.Arccot(-1.0, Cycle => 360.0), + 135.0, + 0.001) or + not FXA5A00.Result_Within_Range(EF.Arccot(-1.0, Cycle => 100.0), + 37.5, + 0.001) + then + Report.Failed("Incorrect results from the Arccot function with " & + "specified Cycle parameter when provided a variety " & + "of X parameter values"); + end if; + + + if not FXA5A00.Result_Within_Range(EF.Arccot(0.2425355, 0.9701420), + EF.Arccot(0.25), + 0.01) or + not FXA5A00.Result_Within_Range(EF.Arccot(0.3162277, 0.9486831), + Ef.Arccot(0.33), + 0.01) + then + Report.Failed("Incorrect results from the Arccot function with " & + "comparison to other Arccot function results"); + end if; + + + if not FXA5A00.Result_Within_Range(EF.Cot(EF.Arccot(0.4472135, + 0.8944270)), + 0.5, + 0.01) or + not FXA5A00.Result_Within_Range(EF.Cot(EF.Arccot(0.9987380, + 0.0499369)), + 20.0, + 0.1) + then + Report.Failed("Incorrect results from the Arccot function when " & + "used as argument to Cot function"); + end if; + + + -- Check that inverse function results are correct. + -- Default Cycle test. + + Angle := 0.001; + while Angle < Pi and not Incorrect_Inverse loop + if not Result_Within_Range(EF.Arccot(EF.Cot(Angle)), Angle, 0.001) + then + Incorrect_Inverse := True; + end if; + Angle := Angle + 0.001; + end loop; + + if Incorrect_Inverse then + Report.Failed("Incorrect results returned from the Inverse " & + "comparison of Cot and Arccot using the default " & + "cycle value"); + Incorrect_Inverse := False; + end if; + + -- Non-Default Cycle test. + + New_Float_Angle := 0.01; + while New_Float_Angle < 180.0 and not Incorrect_Inverse loop + if not Result_Within_Range(EF.Arccot(EF.Cot(Float(New_Float_Angle), + Cycle => 360.0), + Cycle => 360.0), + Float(New_Float_Angle), + 0.01) or + not Result_Within_Range(GEF.Arccot( + New_Float(GEF.Cot(New_Float_Angle, + Cycle => 360.0)), + Cycle => 360.0), + Float(New_Float_Angle), + 0.01) + then + Incorrect_Inverse := True; + end if; + New_Float_Angle := New_Float_Angle + 0.01; + end loop; + + if Incorrect_Inverse then + Report.Failed("Incorrect results returned from the Inverse " & + "comparison of Cot and Arccot using non-default " & + "cycle value"); + 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 CXA5A08; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa5a09.a b/gcc/testsuite/ada/acats/tests/cxa/cxa5a09.a new file mode 100644 index 000000000..22bd2f890 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa5a09.a @@ -0,0 +1,400 @@ +-- CXA5A09.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 Log provides correct results. +-- +-- TEST DESCRIPTION: +-- This test examines both the version of Log resulting from the +-- instantiation of the Ada.Numerics.Generic_Elementary_Functions with +-- with a type derived from type Float,as well as the preinstantiated +-- version of this package for type Float. +-- Prescribed results, including instances prescribed to raise +-- exceptions, are examined in the test cases. In addition, +-- certain evaluations are performed where the actual function result +-- is compared with the expected result (within an epsilon range of +-- accuracy). +-- +-- TEST FILES: +-- The following files comprise this test: +-- +-- FXA5A00.A (foundation code) +-- CXA5A09.A +-- +-- +-- CHANGE HISTORY: +-- 11 Apr 95 SAIC Initial prerelease version. +-- 13 Jun 95 SAIC Incorporated use of Dont_Optimize procedure, and +-- use of Result_Within_Range function overloaded for +-- FXA5A00.New_Float_Type. +-- 29 Jun 98 EDS Protected exception tests by first testing +-- for 'Machine_Overflows +-- +--! + +with Ada.Numerics.Elementary_Functions; +with Ada.Numerics.Generic_Elementary_Functions; +with FXA5A00; +with Report; + +procedure CXA5A09 is +begin + + Report.Test ("CXA5A09", "Check that the Log function provides " & + "correct results"); + + Test_Block: + declare + + use Ada.Numerics; + use FXA5A00; + + package GEF is new Ada.Numerics.Generic_Elementary_Functions(New_Float); + package EF renames Ada.Numerics.Elementary_Functions; + + Arg, + Float_Result : Float := 0.0; + New_Float_Result : New_Float := 0.0; + + Incorrect_Inverse, + Incorrect_Inverse_Base_2, + Incorrect_Inverse_Base_8, + Incorrect_Inverse_Base_10, + Incorrect_Inverse_Base_16 : Boolean := False; + + procedure Dont_Optimize_Float is new Dont_Optimize(Float); + procedure Dont_Optimize_New_Float is new Dont_Optimize(New_Float); + + begin + + -- Testing of Log Function, both instantiated and pre-instantiated + -- version. + + -- Check that Argument_Error is raised when the parameter X is negative. + + begin + New_Float_Result := GEF.Log(X => -1.0); + Report.Failed("Argument_Error not raised by the Log function " & + "when the input parameter is negative"); + Dont_Optimize_New_Float(New_Float_Result, 1); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by the Log function " & + "when the input parameter is negative"); + end; + + begin + Float_Result := EF.Log(X => -FXA5A00.Large); + Report.Failed("Argument_Error not raised by the Log function " & + "when the input parameter is negative"); + Dont_Optimize_Float(Float_Result, 2); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by the Log function " & + "when the input parameter is negative"); + end; + + + -- Check that Constraint_Error is raised when the Log function is + -- provided an input parameter of zero. + + if New_Float'Machine_Overflows = True then + begin + New_Float_Result := GEF.Log(X => 0.0); + Report.Failed("Constraint_Error not raised by the Log function " & + "when the input parameter is zero"); + Dont_Optimize_New_Float(New_Float_Result, 3); + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by the Log function " + & "when the input parameter is zero"); + end; + end if; + + + -- Check for the reference manual prescribed results of the Log function. + + if GEF.Log(X => 1.0) /= 0.0 or + EF.Log(X => 1.0) /= 0.0 + then + Report.Failed("Incorrect result from Function Log when provided " & + "an input parameter value of 1.0"); + end if; + + + -- Check that the Log function provides correct results when provided + -- a variety of input parameters. + + if not FXA5A00.Result_Within_Range(GEF.Log(0.015), -4.20, 0.01) or + not FXA5A00.Result_Within_Range(GEF.Log(0.592), -0.524, 0.001) or + not FXA5A00.Result_Within_Range(GEF.Log(0.997), -0.003, 0.001) or + not FXA5A00.Result_Within_Range(GEF.Log(1.341), 0.293, 0.001) or + not FXA5A00.Result_Within_Range( EF.Log(2.826), 1.04, 0.01) or + not FXA5A00.Result_Within_Range( EF.Log(10.052), 2.31, 0.01) or + not FXA5A00.Result_Within_Range( EF.Log(2569.143), 7.85, 0.01) + then + Report.Failed("Incorrect results from Function Log when provided " & + "a variety of input parameter values"); + end if; + + Arg := 0.001; + while Arg < 1.0 and not Incorrect_Inverse loop + if not Result_Within_Range(EF."**"(e,EF.Log(Arg)), Arg, 0.001) then + Incorrect_Inverse := True; + end if; + Arg := Arg + 0.001; + end loop; + + if Incorrect_Inverse then + Report.Failed("Incorrect inverse result comparing ""**"" and " & + "Log function over argument range 0.001..1.0"); + Incorrect_Inverse := False; + end if; + + Arg := 1.0; + while Arg < 10.0 and not Incorrect_Inverse loop + if not Result_Within_Range(EF."**"(e,EF.Log(Arg)), Arg, 0.01) then + Incorrect_Inverse := True; + end if; + Arg := Arg + 0.01; + end loop; + + if Incorrect_Inverse then + Report.Failed("Incorrect inverse result comparing ""**"" and " & + "Log function over argument range 1.0..10.0"); + Incorrect_Inverse := False; + end if; + + Arg := 1.0; + while Arg < 1000.0 and not Incorrect_Inverse loop + if not Result_Within_Range(EF."**"(e,EF.Log(Arg)), Arg, 0.1) then + Incorrect_Inverse := True; + end if; + Arg := Arg + 1.0; + end loop; + + if Incorrect_Inverse then + Report.Failed("Incorrect inverse result comparing ""**"" and " & + "Log function over argument range 1.0..1000.0"); + end if; + + + -- Testing of Log Function, with specified Base parameter, both + -- instantiated and pre-instantiated versions. + + -- Check that Argument_Error is raised by the Log function with + -- specified Base parameter, when the X parameter value is negative. + + begin + New_Float_Result := GEF.Log(X => -1.0, Base => 16.0); + Report.Failed("Argument_Error not raised by the Log function " & + "with Base parameter, when the input parameter " & + "value is -1.0"); + Dont_Optimize_New_Float(New_Float_Result, 4); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by the Log function " & + "with Base parameter, when the X parameter value " & + "is -1.0"); + end; + + begin + Float_Result := EF.Log(X => -FXA5A00.Large, Base => 8.0); + Report.Failed("Argument_Error not raised by the Log function " & + "with Base parameter, when the X parameter " & + "value is a large negative value"); + Dont_Optimize_Float(Float_Result, 5); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by the Log function " & + "with Base parameter, when the X parameter " & + "value is a large negative value"); + end; + + + -- Check that Argument_Error is raised by the Log function when + -- the specified Base parameter is zero. + + begin + New_Float_Result := GEF.Log(X => 10.0, Base => 0.0); + Report.Failed("Argument_Error not raised by the Log function " & + "with Base parameter of 0.0"); + Dont_Optimize_New_Float(New_Float_Result, 6); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by the Log function " & + "with Base parameter of 0.0"); + end; + + + -- Check that Argument_Error is raised by the Log function when + -- the specified Base parameter is one. + + begin + Float_Result := EF.Log(X => 12.3, Base => 1.0); + Report.Failed("Argument_Error not raised by the Log function " & + "with Base parameter of 1.0"); + Dont_Optimize_Float(Float_Result, 7); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by the Log function " & + "with Base parameter of 1.0"); + end; + + + -- Check that Argument_Error is raised by the Log function when + -- the specified Base parameter is negative. + + begin + New_Float_Result := GEF.Log(X => 12.3, Base => -10.0); + Report.Failed("Argument_Error not raised by the Log function " & + "with negative Base parameter"); + Dont_Optimize_New_Float(New_Float_Result, 8); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by the Log function " & + "with negative Base parameter"); + end; + + + -- Check that Constraint_Error is raised by the Log function when the + -- input X parameter value is 0.0. + + if New_Float'Machine_Overflows = True then + begin + New_Float_Result := GEF.Log(X => 0.0, Base => 16.0); + Report.Failed("Constraint_Error not raised by the Log function " & + "with specified Base parameter, when the value of " & + "the parameter X is 0.0"); + Dont_Optimize_New_Float(New_Float_Result, 9); + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by Function Log" & + "with specified Base parameter, when the value " & + "of the parameter X is 0.0"); + end; + end if; + + -- Check for the prescribed results of the Log function with specified + -- Base parameter. + + if GEF.Log(X => 1.0, Base => 16.0) /= 0.0 or + EF.Log(X => 1.0, Base => 10.0) /= 0.0 or + GEF.Log(1.0, Base => 8.0) /= 0.0 or + EF.Log(1.0, 2.0) /= 0.0 + then + Report.Failed("Incorrect result from Function Log with specified " & + "Base parameter when provided an parameter X input " & + "value of 1.0"); + end if; + + + -- Check that the Log function with specified Base parameter provides + -- correct results when provided a variety of input parameters. + + if not Result_Within_Range(GEF.Log( 10.0, e), 2.30, 0.01) or + not Result_Within_Range( EF.Log( 8.0, 2.0), 3.0, 0.01) or + not Result_Within_Range(GEF.Log(256.0, 2.0), 8.0, 0.01) or + not Result_Within_Range( EF.Log(512.0, 8.0), 3.0, 0.01) or + not Result_Within_Range(GEF.Log(0.5649, e), -0.57, 0.01) or + not Result_Within_Range( EF.Log(1.7714, e), 0.57, 0.01) or + not Result_Within_Range(GEF.Log(0.5718, 10.0), -0.243, 0.001) or + not Result_Within_Range( EF.Log(466.25, 10.0), 2.67, 0.01) + then + Report.Failed("Incorrect results from Function Log with specified " & + "Base parameter, when provided a variety of input " & + "parameter values"); + end if; + + + Arg := 1.0; + while Arg < 1000.0 and + not (Incorrect_Inverse_Base_2 and Incorrect_Inverse_Base_8 and + Incorrect_Inverse_Base_10 and Incorrect_Inverse_Base_16) + loop + if not FXA5A00.Result_Within_Range(EF."**"(2.0,EF.Log(Arg,2.0)), + Arg, + 0.001) + then + Incorrect_Inverse_Base_2 := True; + end if; + if not FXA5A00.Result_Within_Range(EF."**"(8.0,EF.Log(Arg,8.0)), + Arg, + 0.001) + then + Incorrect_Inverse_Base_8 := True; + end if; + if not FXA5A00.Result_Within_Range(EF."**"(10.0,EF.Log(Arg,10.0)), + Arg, + 0.001) + then + Incorrect_Inverse_Base_10 := True; + end if; + if not FXA5A00.Result_Within_Range(EF."**"(16.0,EF.Log(Arg,16.0)), + Arg, + 0.001) + then + Incorrect_Inverse_Base_16 := True; + end if; + Arg := Arg + 1.0; + end loop; + + if Incorrect_Inverse_Base_2 then + Report.Failed("Incorrect inverse result comparing ""**"" and " & + "Log function for Base 2"); + end if; + + if Incorrect_Inverse_Base_8 then + Report.Failed("Incorrect inverse result comparing ""**"" and " & + "Log function for Base 8"); + end if; + + if Incorrect_Inverse_Base_10 then + Report.Failed("Incorrect inverse result comparing ""**"" and " & + "Log function for Base 10"); + end if; + + if Incorrect_Inverse_Base_16 then + Report.Failed("Incorrect inverse result comparing ""**"" and " & + "Log function for Base 16"); + end if; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + +end CXA5A09; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa5a10.a b/gcc/testsuite/ada/acats/tests/cxa/cxa5a10.a new file mode 100644 index 000000000..4804d6729 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa5a10.a @@ -0,0 +1,551 @@ +-- CXA5A10.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 functions Exp and Sqrt, and the exponentiation +-- operator "**" provide correct results. +-- +-- TEST DESCRIPTION: +-- This test examines both the versions of Exp, Sqrt, and "**" +-- resulting from the instantiation of the +-- Ada.Numerics.Generic_Elementary_Functions with a type derived from +-- type Float, as well as the preinstantiated version of this package +-- for type Float. +-- Prescribed results (stated as such in the reference manual), +-- including instances prescribed to raise exceptions, are examined +-- in the test cases. In addition, certain evaluations are performed +-- for the preinstantiated package where the actual function result is +-- compared with the expected result (within an epsilon range of +-- accuracy). +-- +-- TEST FILES: +-- The following files comprise this test: +-- +-- FXA5A00.A (foundation code) +-- CXA5A10.A +-- +-- +-- CHANGE HISTORY: +-- 17 Apr 95 SAIC Initial prerelease version. +-- 13 Jun 95 SAIC Incorporated use of Dont_Optimize procedure, and +-- use of Result_Within_Range function overloaded for +-- FXA5A00.New_Float_Type. +-- 18 Apr 96 SAIC Incorporated reviewer comments for ACVC 2.1. +-- 01 Oct 01 RLB Protected Constraint_Error exception tests by +-- first testing for 'Machine_Overflows. +-- +--! + +with Ada.Exceptions; +with Ada.Numerics.Elementary_Functions; +with Ada.Numerics.Generic_Elementary_Functions; +with FXA5A00; +with Report; + +procedure CXA5A10 is +begin + + Report.Test ("CXA5A10", "Check that Exp, Sqrt, and the ""**"" operator " & + "provide correct results"); + + Test_Block: + declare + + use FXA5A00, Ada.Numerics; + use Ada.Exceptions; + + package GEF is new Ada.Numerics.Generic_Elementary_Functions(New_Float); + package EF renames Ada.Numerics.Elementary_Functions; + + use GEF, EF; + + Arg, + Float_Result : Float; + New_Float_Result : New_Float; + + Flag_1, Flag_2, Flag_3, Flag_4, + Incorrect_Inverse_Base_e, + Incorrect_Inverse_Base_2, + Incorrect_Inverse_Base_8, + Incorrect_Inverse_Base_10, + Incorrect_Inverse_Base_16 : Boolean := False; + + procedure Dont_Optimize_Float is new Dont_Optimize(Float); + procedure Dont_Optimize_New_Float is new Dont_Optimize(New_Float); + + begin + + -- Testing of the "**" operator, both instantiated and pre-instantiated + -- version. + + -- Check that Argument_Error is raised by the exponentiation operator + -- when the value of the Left parameter (operand) is negative. + + begin + New_Float_Result := GEF."**"(Left => -10.0, + Right => 2.0); + Report.Failed("Argument_Error not raised by the instantiated " & + "version of the exponentiation operator when the " & + "value of the Left parameter is negative"); + Dont_Optimize_New_Float(New_Float_Result, 1); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by the " & + "instantiated version of the exponentiation " & + "operator when the value of the Left parameter " & + "is negative"); + end; + + begin + Float_Result := (-FXA5A00.Small) ** 4.0; + Report.Failed("Argument_Error not raised by the preinstantiated " & + "version of the exponentiation operator when the " & + "value of the Left parameter is negative"); + Dont_Optimize_Float(Float_Result, 2); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by the " & + "preinstantiated version of the exponentiation " & + "operator when the value of the Left parameter " & + "is negative"); + end; + + + -- Check that Argument_Error is raised by the exponentiation operator + -- when both parameters (operands) have the value 0.0. + + begin + New_Float_Result := GEF."**"(0.0, Right => 0.0); + Report.Failed("Argument_Error not raised by the instantiated " & + "version of the exponentiation operator when " & + "both operands are zero"); + Dont_Optimize_New_Float(New_Float_Result, 3); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by the " & + "instantiated version of the exponentiation " & + "operator when both operands are zero"); + end; + + begin + Float_Result := 0.0**0.0; + Report.Failed("Argument_Error not raised by the preinstantiated " & + "version of the exponentiation operator when both " & + "operands are zero"); + Dont_Optimize_Float(Float_Result, 4); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by the " & + "preinstantiated version of the exponentiation " & + "operator when both operands are zero"); + end; + + + -- Check that Constraint_Error is raised by the exponentiation + -- operator when the value of the left parameter (operand) is zero, + -- and the value of the right parameter (exponent) is negative. + -- This check applies only if Machine_Overflows is true [A.5.1(28, 30)]. + + if New_Float'Machine_Overflows = True then + begin + New_Float_Result := GEF."**"(0.0, Right => -2.0); + Report.Failed("Constraint_Error not raised by the instantiated " & + "version of the exponentiation operator when " & + "the left parameter is 0.0, and the right " & + "parameter is negative"); + Dont_Optimize_New_Float(New_Float_Result, 5); + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by the " & + "instantiated version of the exponentiation " & + "operator when the left parameter is 0.0, " & + "and the right parameter is negative"); + end; + end if; + + if Float'Machine_Overflows = True then + begin + Float_Result := 0.0 ** (-FXA5A00.Small); + Report.Failed("Constraint_Error not raised by the " & + "preinstantiated version of the exponentiation " & + "operator when the left parameter is 0.0, and the " & + "right parameter is negative"); + Dont_Optimize_Float(Float_Result, 6); + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by the " & + "preinstantiated version of the exponentiation " & + "operator when the left parameter is 0.0, and " & + "the right parameter is negative"); + end; + end if; + + -- Prescribed results. + -- Check that exponentiation by a 0.0 exponent yields the value one. + + if GEF."**"(Left => 10.0, Right => 0.0) /= 1.0 or + EF."**"(FXA5A00.Large, Right => 0.0) /= 1.0 or + GEF."**"(3.0, 0.0) /= 1.0 or + FXA5A00.Small ** 0.0 /= 1.0 + then + Report.Failed("Incorrect results returned from the ""**"" " & + "operator when the value of the exponent is 0.0"); + end if; + + + -- Check that exponentiation by a unit exponent yields the value + -- of the left operand. + + if GEF."**"(Left => 50.0, Right => 1.0) /= 50.0 or + EF."**"(FXA5A00.Large, Right => 1.0) /= FXA5A00.Large or + GEF."**"(6.0, 1.0) /= 6.0 or + FXA5A00.Small ** 1.0 /= FXA5A00.Small + then + Report.Failed("Incorrect results returned from the ""**"" " & + "operator when the value of the exponent is 1.0"); + end if; + + + -- Check that exponentiation of the value 1.0 yields the value 1.0. + + if GEF."**"(Left => 1.0, Right => 16.0) /= 1.0 or + EF."**"(1.0, Right => FXA5A00.Large) /= 1.0 or + GEF."**"(1.0, 3.0) /= 1.0 or + 1.0 ** FXA5A00.Small /= 1.0 + then + Report.Failed("Incorrect results returned from the ""**"" " & + "operator when the value of the operand is 1.0"); + end if; + + + -- Check that exponentiation of the value 0.0 yields the value 0.0. + + if GEF."**"(Left => 0.0, Right => 10.0) /= 0.0 or + EF."**"(0.0, Right => FXA5A00.Large) /= 0.0 or + GEF."**"(0.0, 4.0) /= 0.0 or + 0.0 ** FXA5A00.Small /= 0.0 + then + Report.Failed("Incorrect results returned from the ""**"" " & + "operator when the value of the operand is 0.0"); + end if; + + + -- Check that exponentiation of various operands with a variety of + -- of exponent values yield correct results. + + if not Result_Within_Range(GEF."**"(5.0, 2.0), 25.0, 0.01) or + not Result_Within_Range(GEF."**"(1.225, 1.5), 1.36, 0.01) or + not Result_Within_Range(GEF."**"(0.26, 2.0), 0.068, 0.001) or + not Result_Within_Range( EF."**"(e, 5.0), 148.4, 0.1) or + not Result_Within_Range( EF."**"(10.0, e), 522.7, 0.1) or + not Result_Within_Range( EF."**"(e, (-3.0)), 0.050, 0.001) or + not Result_Within_Range(GEF."**"(10.0,(-2.0)), 0.010, 0.001) + then + Report.Failed("Incorrect results returned from the ""**"" " & + "operator with a variety of operand and exponent " & + "values"); + end if; + + + -- Use the following loops to check for internal consistency between + -- inverse functions. + + declare + -- Use the relative error value to account for non-exact + -- computations. + TC_Relative_Error: Float := 0.005; + begin + for i in 1..5 loop + for j in 0..5 loop + if not Incorrect_Inverse_Base_e and + not FXA5A00.Result_Within_Range + (Float(i)**Float(j), + e**(Float(j)*EF.Log(Float(i))), + TC_Relative_Error) + then + Incorrect_Inverse_Base_e := True; + Report.Failed("Incorrect Log-** Inverse calc for Base e " & + "with i= " & Integer'Image(i) & " and j= " & + Integer'Image(j)); + end if; + if not Incorrect_Inverse_Base_2 and + not FXA5A00.Result_Within_Range + (Float(i)**Float(j), + 2.0**(Float(j)*EF.Log(Float(i),2.0)), + TC_Relative_Error) + then + Incorrect_Inverse_Base_2 := True; + Report.Failed("Incorrect Log-** Inverse calc for Base 2 " & + "with i= " & Integer'Image(i) & " and j= " & + Integer'Image(j)); + end if; + if not Incorrect_Inverse_Base_8 and + not FXA5A00.Result_Within_Range + (Float(i)**Float(j), + 8.0**(Float(j)*EF.Log(Float(i),8.0)), + TC_Relative_Error) + then + Incorrect_Inverse_Base_8 := True; + Report.Failed("Incorrect Log-** Inverse calc for Base 8 " & + "with i= " & Integer'Image(i) & " and j= " & + Integer'Image(j)); + end if; + if not Incorrect_Inverse_Base_10 and + not FXA5A00.Result_Within_Range + (Float(i)**Float(j), + 10.0**(Float(j)*EF.Log(Float(i),10.0)), + TC_Relative_Error) + then + Incorrect_Inverse_Base_10 := True; + Report.Failed("Incorrect Log-** Inverse calc for Base 10 " & + "with i= " & Integer'Image(i) & " and j= " & + Integer'Image(j)); + end if; + if not Incorrect_Inverse_Base_16 and + not FXA5A00.Result_Within_Range + (Float(i)**Float(j), + 16.0**(Float(j)*EF.Log(Float(i),16.0)), + TC_Relative_Error) + then + Incorrect_Inverse_Base_16 := True; + Report.Failed("Incorrect Log-** Inverse calc for Base 16 " & + "with i= " & Integer'Image(i) & " and j= " & + Integer'Image(j)); + end if; + end loop; + end loop; + end; + + -- Reset Flags. + Incorrect_Inverse_Base_e := False; + Incorrect_Inverse_Base_2 := False; + Incorrect_Inverse_Base_8 := False; + Incorrect_Inverse_Base_10 := False; + Incorrect_Inverse_Base_16 := False; + + + -- Testing of Exp Function, both instantiated and pre-instantiated + -- version. + + -- Check that the result of the Exp Function, when provided an X + -- parameter value of 0.0, is 1.0. + + if GEF.Exp(X => 0.0) /= 1.0 or + EF.Exp(0.0) /= 1.0 + then + Report.Failed("Incorrect result returned by Function Exp when " & + "given a parameter value of 0.0"); + end if; + + + -- Check that the Exp Function provides correct results when provided + -- a variety of input parameter values. + + if not Result_Within_Range(GEF.Exp(0.001), 1.01, 0.01) or + not Result_Within_Range( EF.Exp(0.1), 1.11, 0.01) or + not Result_Within_Range(GEF.Exp(1.2697), 3.56, 0.01) or + not Result_Within_Range( EF.Exp(3.2525), 25.9, 0.1) or + not Result_Within_Range(GEF.Exp(-0.2198), 0.803, 0.001) or + not Result_Within_Range( EF.Exp(-1.6621), 0.190, 0.001) or + not Result_Within_Range(GEF.Exp(-2.3888), 0.092, 0.001) or + not Result_Within_Range( EF.Exp(-5.4415), 0.004, 0.001) + then + Report.Failed("Incorrect result from Function Exp when provided " & + "a variety of input parameter values"); + end if; + + -- Use the following loops to check for internal consistency between + -- inverse functions. + + Arg := 0.01; + while Arg < 10.0 loop + if not Incorrect_Inverse_Base_e and + FXA5A00.Result_Within_Range(EF.Exp(Arg), + e**(Arg*EF.Log(Arg)), + 0.001) + then + Incorrect_Inverse_Base_e := True; + Report.Failed("Incorrect Exp-** Inverse calc for Base e"); + end if; + if not Incorrect_Inverse_Base_2 and + FXA5A00.Result_Within_Range(EF.Exp(Arg), + 2.0**(Arg*EF.Log(Arg,2.0)), + 0.001) + then + Incorrect_Inverse_Base_2 := True; + Report.Failed("Incorrect Exp-** Inverse calc for Base 2"); + end if; + if not Incorrect_Inverse_Base_8 and + FXA5A00.Result_Within_Range(EF.Exp(Arg), + 8.0**(Arg*EF.Log(Arg,8.0)), + 0.001) + then + Incorrect_Inverse_Base_8 := True; + Report.Failed("Incorrect Exp-** Inverse calc for Base 8"); + end if; + if not Incorrect_Inverse_Base_10 and + FXA5A00.Result_Within_Range(EF.Exp(Arg), + 10.0**(Arg*EF.Log(Arg,10.0)), + 0.001) + then + Incorrect_Inverse_Base_10 := True; + Report.Failed("Incorrect Exp-** Inverse calc for Base 10"); + end if; + if not Incorrect_Inverse_Base_16 and + FXA5A00.Result_Within_Range(EF.Exp(Arg), + 16.0**(Arg*EF.Log(Arg,16.0)), + 0.001) + then + Incorrect_Inverse_Base_16 := True; + Report.Failed("Incorrect Exp-** Inverse calc for Base 16"); + end if; + Arg := Arg + 0.01; + end loop; + + + -- Testing of Sqrt Function, both instantiated and pre-instantiated + -- version. + + -- Check that Argument_Error is raised by the Sqrt Function when + -- the value of the input parameter X is negative. + + begin + Float_Result := EF.Sqrt(X => -FXA5A00.Small); + Report.Failed("Argument_Error not raised by Function Sqrt " & + "when provided a small negative input parameter " & + "value"); + Dont_Optimize_Float(Float_Result, 7); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by Function Sqrt " & + "when provided a small negative input parameter " & + "value"); + end; + + begin + New_Float_Result := GEF.Sqrt(X => -64.0); + Report.Failed("Argument_Error not raised by Function Sqrt " & + "when provided a large negative input parameter " & + "value"); + Dont_Optimize_New_Float(New_Float_Result, 8); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by Function Sqrt " & + "when provided a large negative input parameter " & + "value"); + end; + + + -- Check that the Sqrt Function, when given an X parameter value of 0.0, + -- returns a result of 0.0. + + if GEF.Sqrt(X => 0.0) /= 0.0 or + EF.Sqrt(0.0) /= 0.0 + then + Report.Failed("Incorrect result from Function Sqrt when provided " & + "an input parameter value of 0.0"); + end if; + + + -- Check that the Sqrt Function, when given an X parameter input value + -- of 1.0, returns a result of 1.0. + + if GEF.Sqrt(X => 1.0) /= 1.0 or + EF.Sqrt(1.0) /= 1.0 + then + Report.Failed("Incorrect result from Function Sqrt when provided " & + "an input parameter value of 1.0"); + end if; + + + -- Check that the Sqrt Function provides correct results when provided + -- a variety of input parameter values. + + if not FXA5A00.Result_Within_Range(GEF.Sqrt(0.0327), 0.181, 0.001) or + not FXA5A00.Result_Within_Range( EF.Sqrt(0.1808), 0.425, 0.001) or + not FXA5A00.Result_Within_Range(GEF.Sqrt(1.0556), 1.03, 0.01) or + not FXA5A00.Result_Within_Range( EF.Sqrt(32.8208), 5.73, 0.01) or + not FXA5A00.Result_Within_Range( EF.Sqrt(27851.0), 166.9, 0.1) or + not FXA5A00.Result_Within_Range( EF.Sqrt(61203.4), 247.4, 0.1) or + not FXA5A00.Result_Within_Range( EF.Sqrt(655891.0), 809.9, 0.1) + then + Report.Failed("Incorrect result from Function Sqrt when provided " & + "a variety of input parameter values"); + end if; + + -- Check internal consistency between functions. + + Arg := 0.01; + while Arg < 10.0 loop + if not Flag_1 and + not FXA5A00.Result_Within_Range(Arg, + EF.Sqrt(Arg)*EF.Sqrt(Arg), + 0.01) + then + Report.Failed("Inconsistency found in Case 1"); + Flag_1 := True; + end if; + if not Flag_2 and + not FXA5A00.Result_Within_Range(Arg, EF.Sqrt(Arg)**2.0, 0.01) + then + Report.Failed("Inconsistency found in Case 2"); + Flag_2 := True; + end if; + if not Flag_3 and + not FXA5A00.Result_Within_Range(EF.Log(Arg), + EF.Log(Sqrt(Arg)**2.0), 0.01) + then + Report.Failed("Inconsistency found in Case 3"); + Flag_3 := True; + end if; + if not Flag_4 and + not FXA5A00.Result_Within_Range(EF.Log(Arg), + 2.00*EF.Log(EF.Sqrt(Arg)), + 0.01) + then + Report.Failed("Inconsistency found in Case 4"); + Flag_4 := True; + end if; + Arg := Arg + 1.0; + 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 CXA5A10; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa8001.a b/gcc/testsuite/ada/acats/tests/cxa/cxa8001.a new file mode 100644 index 000000000..16f30752d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa8001.a @@ -0,0 +1,243 @@ +-- CXA8001.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 all elements to be transferred to a sequential file of +-- mode Append_File will be placed following the last element currently +-- in the file. +-- Check that it is possible to append data to a file that has been +-- previously appended to. +-- Check that the predefined procedure Write will place an element after +-- the last element in the file in mode Append_File. +-- +-- TEST DESCRIPTION: +-- This test implements a sequential file system that has the capability +-- to store data records at the end of a file. Initially, the file is +-- opened with mode Out_File, and data is written to the file. The file +-- is closed, then reopened with mode Append_File. An additional record +-- is written, and again the file is closed. The file is then reopened, +-- again with mode Append_File, and another record is written to the +-- file. +-- The file is closed again, the reopened with mode In_File, and the data +-- in the file is read and checked for proper ordering within the file. +-- +-- An expected common usage of Append_File mode would be in the opening +-- of a file that currently contains data. Likewise, the reopening of +-- files in Append_Mode that have been previously appended to for the +-- addition of more data would be frequently encountered. This test +-- attempts to simulate both situations. (Of course, in an actual user +-- environment, the open/write/close processing would be performed using +-- looping structures, rather than the straight-line processing displayed +-- here.) +-- +-- APPLICABILITY CRITERIA: +-- Applicable to all systems capable of supporting IO operations on +-- external Sequential_IO files. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 27 Feb 97 PWB.CTA Allowed for non-support of some IO operations +--! + +with Sequential_IO; +with Report; + +procedure CXA8001 is + + -- Declare data types and objects to be stored in the file. + subtype Name_Type is String (1 .. 10); + type Tickets is range 0 .. 1000; + + type Order_Type is record + Name : Name_Type; + No_of_Tickets : Tickets; + end record; + + package Order_IO is new Sequential_IO (Order_Type); -- Declare Seq_IO + -- package, + Order_File : Order_IO.File_Type; -- and file object. + Order_Filename : constant String := + Report.Legal_File_Name ( Nam => "CXA8001" ); + Incomplete : exception; + +begin + + Report.Test ("CXA8001", "Check that all elements to be transferred to a " & + "sequential file of mode Append_File will be " & + "placed following the last element currently " & + "in the file"); + + Test_for_Sequential_IO_Support: + begin + + -- An implementation that does not support Sequential_IO in a particular + -- environment will raise Use_Error or Name_Error on calls to various + -- Sequential_IO operations. This block statement encloses a call to + -- Create, which should produce an exception in a non-supportive + -- environment. These exceptions will be handled to produce a + -- Not_Applicable result. + + Order_IO.Create (File => Order_File, -- Create Sequential_IO file + Mode => Order_IO.Out_File, -- with mode Out_File. + Name => Order_Filename); + + exception + + when Order_IO.Use_Error | Order_IO.Name_Error => + Report.Not_Applicable + ( "Files not supported - Create as Out_File for Sequential_IO" ); + raise Incomplete; + + end Test_for_Sequential_IO_Support; + + Operational_Test_Block: + declare + -- Assign values into the component fields of the data objects. + Buyer_1 : constant Order_Type := ("John Smith", 3); + Buyer_2 : constant Order_Type := + (Name => "Jane Jones", No_of_Tickets => 2); + Buyer_3 : Order_Type := ("Mike Brown", 5); + + begin + Order_IO.Write (File => Order_File, -- Write initial data item + Item => Buyer_1); -- to file. + + Order_IO.Close (File => Order_File); -- Close file. + + -- + -- Enter additional data records into the file. (Append to a file of + -- previous mode Out_File). + -- + Order_IO.Open (Order_File, -- Open Sequential_IO file + Order_IO.Append_File, -- with mode Append_File. + Order_Filename); + + Order_IO.Write (Order_File, Buyer_2); -- Write second data item + -- to file. + Order_IO.Close (File => Order_File); -- Close file. + + -- Check to determine whether file is actually closed. + begin + Order_IO.Write (Order_File, Buyer_2); + Report.Failed("Exception not raised on Write to Closed file"); + exception + when Order_IO.Status_Error => null; -- Expected exception. + when others => + Report.Failed("Incorrect exception on Write to Closed file"); + end; + + -- + -- The following code segment demonstrates appending data to a file + -- that has been previously appended to. + -- + + Order_IO.Open (Order_File, -- Open Sequential_IO file + Order_IO.Append_File, -- with mode Append_File. + Order_Filename ); + + Order_IO.Write (Order_File, Buyer_3); -- Write third data item + -- to file. + Order_IO.Close (File => Order_File); -- Close file. + + + Test_Verification_Block: + declare + TC_Order1, TC_Order2, TC_Order3 : Order_Type; + begin + + Order_IO.Open (Order_File, -- Open Sequential_IO file + Order_IO.In_File, -- with mode In_File. + Order_Filename ); + + Order_IO.Read (File => Order_File, -- Read records from file. + Item => TC_Order1); + Order_IO.Read (Order_File, TC_Order2); + Order_IO.Read (Order_File, TC_Order3); + + -- Compare the contents of each with the individual data items. + -- If items read from file do not match the items placed into + -- the file, in the appropriate order, then fail. + + if ((TC_Order1 /= Buyer_1) or + (TC_Order2.Name /= Buyer_2.Name) or + (TC_Order2.No_of_Tickets /= Buyer_2.No_of_Tickets) or + not ((TC_Order3.Name = "Mike Brown") and + (TC_Order3.No_of_Tickets = 5))) then + Report.Failed ("Incorrect appending of record data in file"); + end if; + + -- Check to determine that no more than three data records were + -- actually written to the file. + if not Order_IO.End_Of_File (Order_File) then + Report.Failed("File not empty after three reads"); + end if; + + exception + + when Order_IO.End_Error => -- If three items not in + -- file (data overwritten), + -- then fail. + Report.Failed ("Incorrect number of record elements in file"); + + when others => + Report.Failed ("Error raised during data verification"); + + end Test_Verification_Block; + + exception + + when others => + Report.Failed("Exception raised during Sequential_IO processing"); + + end Operational_Test_Block; + + Deletion: + begin + -- Check that file is open prior to deleting it. + if Order_IO.Is_Open(Order_File) then + Order_IO.Delete (Order_File); + else + Order_IO.Open(Order_File, Order_IO.In_File, Order_Filename); + Order_IO.Delete (Order_File); + end if; + + exception + when others => + Report.Failed + ( "Delete not properly implemented for Sequential_IO" ); + + end Deletion; + + Report.Result; + +exception + when Incomplete => + Report.Result; + when others => + Report.Failed ( "Unexpected exception" ); + Report.Result; + +end CXA8001; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa8002.a b/gcc/testsuite/ada/acats/tests/cxa/cxa8002.a new file mode 100644 index 000000000..8670e98ba --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa8002.a @@ -0,0 +1,285 @@ +-- CXA8002.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 resetting a file using mode Append_File allows for the +-- writing of elements to the file starting after the last element in +-- the file. +-- Check that the result of function Name can be used on a subsequent +-- reopen of the file. +-- Check that a mode change occurs on reset of a file to/from mode +-- Append_File. +-- +-- TEST DESCRIPTION: +-- This test simulates the read/write of data from/to an individual +-- sequential file. New data can be appended to the end of the existing +-- file, and the same file can be reset to allow reading of data from +-- the file. This process can occur multiple times. +-- When the mode of the file is changed with a Reset, the current mode +-- value assigned to the file is checked using the result of function +-- Mode. This, in conjunction with the read/write operations, verifies +-- that a mode change has taken place on Reset. +-- +-- An expected common usage of the scenarios found in this test would +-- be a case where a single data file is kept open continuously, being +-- reset for read/append of data. For systems that do not support a +-- direct form of I/O, this would allow for efficient use of a sequential +-- I/O file. +-- +-- APPLICABILITY CRITERIA: +-- Applicable to all systems capable of supporting IO operations on +-- external Sequential_IO files. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 19 Feb 97 PWB.CTA Fixed handling for file non-support and Reset +-- non-support. +--! + +with Sequential_IO; +with Report; + +procedure CXA8002 is + subtype Employee_Data is String (1 .. 11); + package Data_IO is new Sequential_IO (Employee_Data); + + Employee_Data_File : Data_IO.File_Type; + Employee_Filename : constant String := + Report.Legal_File_Name (Nam => "CXA8002"); + + Incomplete : exception; + +begin + + Report.Test ("CXA8002", "Check that resetting a file using mode " & + "Append_File allows for the writing of " & + "elements to the file starting after the " & + "last element in the file"); + + Test_for_Sequential_IO_Support: + begin + + -- An implementation that does not support Sequential_IO in a particular + -- environment will raise Use_Error or Name_Error on calls to various + -- Sequential_IO operations. This block statement encloses a call to + -- Create, which should produce an exception in a non-supportive + -- environment. These exceptions will be handled to produce a + -- Not_Applicable result. + + Data_IO.Create (File => Employee_Data_File, -- Create file in + Mode => Data_IO.Append_File, -- mode Append_File. + Name => Employee_Filename); + + -- + -- The following portion of code demonstrates the fact that a sequential + -- file can be created in Append_File mode, and that data can be written + -- to the file. + -- + + exception + when Data_IO.Use_Error | Data_IO.Name_Error => + Report.Not_Applicable + ( "Sequential files not supported - Create as Append_File"); + raise Incomplete; + end Test_for_Sequential_IO_Support; + Operational_Test_Block: + declare + Blank_Data : constant Employee_Data := " "; + Employee_1 : constant Employee_Data := "123-45-6789"; + Employee_2 : Employee_Data := "987-65-4321"; + + -- Note: Artificial numerical data chosen above to prevent any + -- unintended similarity with persons alive or dead. + + TC_Employee_Data : Employee_Data := Blank_Data; + + + function TC_Mode_Selection (Selector : Integer) + return Data_IO.File_Mode is + begin + case Report.Ident_Int(Selector) is + when 1 => return Data_IO.In_File; + when 2 => return Data_IO.Out_File; + when others => return Data_IO.Append_File; + end case; + end TC_Mode_Selection; + + Employee_Filename : constant String := -- Use function Name to + Data_IO.Name (File => Employee_Data_File); -- store filename in + -- string variable. + begin + + Data_IO.Write (File => Employee_Data_File, -- Write initial data + Item => Employee_1); -- entry to file. + + -- + -- The following portion of code demonstrates that a sequential file + -- can be reset to various file modes, including Append_File mode, + -- allowing data to be added to the end of the file. + -- + begin + Data_IO.Reset (File => Employee_Data_File, -- Reset file with + Mode => Data_IO.In_File); -- mode In_File. + exception + when Data_IO.Use_Error => + Report.Not_Applicable + ("Reset to In_File not supported for Sequential_IO"); + raise Incomplete; + when others => + Report.Failed + ("Unexpected exception on Reset to In_File (Sequential_IO)"); + raise Incomplete; + end; + if Data_IO."="(Data_IO.Mode (Employee_Data_File), + TC_Mode_Selection (1)) then -- Compare In_File mode + -- Reset successful, + Data_IO.Read (File => Employee_Data_File, -- now verify file data. + Item => TC_Employee_Data); + + if ((TC_Employee_Data (1 .. 7) /= "123-45-") or + (TC_Employee_Data (5 .. 11) /= "45-6789")) then + Report.Failed ("Data read error"); + end if; + + else + Report.Failed ("File mode not changed by Reset"); + end if; + + -- + -- Simulate appending data to a file that has previously been written + -- to and read from. + -- + begin + Data_IO.Reset (File => Employee_Data_File, -- Reset file with + Mode => Data_IO.Append_File); -- mode Append_File. + exception + when Data_IO.Use_Error => + Report.Not_Applicable + ("Reset to Append_File not supported for Sequential_IO"); + raise Incomplete; + when others => + Report.Failed + ("Unexpected exception on Reset to Append_File (Sequential_IO)"); + raise Incomplete; + end; + + if Data_IO.Is_Open (Employee_Data_File) then -- File remains open + -- following Reset to + -- Append_File mode? + + if Data_IO."=" (Data_IO.Mode (Employee_Data_File), + TC_Mode_Selection (3)) then -- Compare to + -- Append_File mode. + Data_IO.Write (File => Employee_Data_File, -- Write additional + Item => Employee_2); -- data to file. + else + Report.Failed ("File mode not changed by Reset"); + end if; + + else + Report.Failed + ("File status not Open following Reset to Append mode"); + end if; + + Data_IO.Close (Employee_Data_File); + + + Test_Verification_Block: + begin + + Data_IO.Open (File => Employee_Data_File, -- Reopen file, using + Mode => Data_IO.In_File, -- previous result of + Name => Employee_Filename); -- function Name. + + TC_Employee_Data := Blank_Data; -- Clear record field. + Data_IO.Read (Employee_Data_File, -- Read first record, + TC_Employee_Data); -- check ordering of + -- records. + + if not ((TC_Employee_Data (1 .. 3) = "123") and then + (TC_Employee_Data (4 .. 11) = "-45-6789")) then + Report.Failed ("Data read error - first record"); + end if; + + TC_Employee_Data := Blank_Data; -- Clear record field. + Data_IO.Read (Employee_Data_File, -- Read second record, + TC_Employee_Data); -- check for ordering of + -- records. + + if ((TC_Employee_Data (1 .. 6) /= "987-65") or else + not (TC_Employee_Data (3 .. 11) = "7-65-4321")) then + Report.Failed ("Data read error - second record"); + end if; + + -- Check that only two items were written to the file. + if not Data_IO.End_Of_File(Employee_Data_File) then + Report.Failed("Incorrect number of records in file"); + end if; + + exception + + when Data_IO.End_Error => -- If two items not in + -- file (data overwritten), + -- then fail. + Report.Failed ("Incorrect number of record elements in file"); + + when others => + Report.Failed ("Error raised during data verification"); + + end Test_Verification_Block; + + exception + + when others => + Report.Failed("Exception raised during Sequential_IO processing"); + + end Operational_Test_Block; + + Final_Block: + begin + -- Check that file is open prior to deleting it. + if Data_IO.Is_Open(Employee_Data_File) then + Data_IO.Delete (Employee_Data_File); + else + Data_IO.Open(Employee_Data_File, + Data_IO.In_File, + Employee_Filename); + Data_IO.Delete (Employee_Data_File); + end if; + exception + when others => + Report.Failed ("Sequential_IO Delete not properly supported"); + end Final_Block; + + Report.Result; + +exception + when Incomplete => + Report.Result; + when others => + Report.Failed ("Unexpected exception"); + Report.Result; +end CXA8002; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa8003.a b/gcc/testsuite/ada/acats/tests/cxa/cxa8003.a new file mode 100644 index 000000000..cf9b5e075 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa8003.a @@ -0,0 +1,214 @@ +-- CXA8003.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 Append_File mode has not been added to package Direct_IO. +-- +-- TEST DESCRIPTION: +-- This test uses a procedure to change the mode of an existing Direct_IO +-- file. The file descriptor is passed as a parameter, along with a +-- numeric indicator for the new mode. Based on the numeric parameter, +-- a Direct_IO.Reset is performed using a File_Mode'Value transformation +-- of a string constant into a File_Mode value. An attempt to reset a +-- Direct_IO file to mode Append_File should cause an Constraint_Error +-- to be raised, as Append_File mode has not been added to Direct_IO in +-- Ada 9X. +-- +-- APPLICABILITY CRITERIA: +-- This test is applicable to all implementations supporting Direct_IO +-- files. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 19 Feb 97 PWB.CTA Allowed for non-support of Reset for certain +-- modes. +--! + +with Direct_IO; +with Report; + +procedure CXA8003 is + Incomplete : exception; + begin + + Report.Test ("CXA8003", "Check that Append_File mode has not " & + "been added to package Direct_IO"); + + Test_for_Direct_IO_Support: + declare + + subtype String_Data_Type is String (1 .. 20); + type Numeric_Data_Type is range 1 .. 512; + type Composite_Data_Type is array (1 .. 3) of String_Data_Type; + + type File_Data_Type is record + Data_Field_1 : String_Data_Type; + Data_Field_2 : Numeric_Data_Type; + Data_Field_3 : Composite_Data_Type; + end record; + + package Dir_IO is new Direct_IO (File_Data_Type); + + Data_File : Dir_IO.File_Type; + Dir_Filename : constant String := Report.Legal_File_Name; + + begin + + -- An application creates a text file with mode Out_File. + -- Use_Error will be raised if Direct_IO operations or external + -- files are not supported. + + Dir_IO.Create (Data_File, + Dir_IO.Out_File, + Dir_Filename); + + Change_File_Mode: + declare + + TC_Append_Test_Executed : Boolean := False; + + type Mode_Selection_Type is ( A, I, IO, O ); + + + procedure Change_Mode (File : in out Dir_IO.File_Type; + To : in Mode_Selection_Type) is + begin + case To is + when A => + TC_Append_Test_Executed := True; + Dir_IO.Reset + (File, Dir_IO.File_Mode'Value("Append_File")); + when I => + begin + Dir_IO.Reset + (File, Dir_IO.File_Mode'Value("In_File")); + exception + when Dir_IO.Use_Error => + Report.Not_Applicable + ("Reset to In_File not supported: Direct_IO"); + raise Incomplete; + end; + when IO => + begin + Dir_IO.Reset + (File, Dir_IO.File_Mode'Value("Inout_File")); + exception + when Dir_IO.Use_Error => + Report.Not_Applicable + ("Reset to InOut_File not supported: Direct_IO"); + raise Incomplete; + end; + when O => + begin + Dir_IO.Reset + (File, Dir_IO.File_Mode'Value("Out_File")); + exception + when Dir_IO.Use_Error => + Report.Not_Applicable + ("Reset to Out_File not supported: Direct_IO"); + raise Incomplete; + end; + end case; + end Change_Mode; + + + begin + + -- At some point in the processing, the application may call a + -- procedure to change the mode of the file (perhaps for + -- additional data entry, data verification, etc.). It is at + -- this point that a use of Append_File mode for a Direct_IO + -- file would cause an exception. + + for I in reverse Mode_Selection_Type loop + Change_Mode (Data_File, I); + Report.Comment + ("Mode changed to " & + Dir_IO.File_Mode'Image (Dir_IO.Mode (Data_File))); + end loop; + + Report.Failed("No error raised on change to Append_File mode"); + + exception + + -- A handler has been provided in the application, which + -- handles the constraint error, allowing processing to + -- continue. + + when Constraint_Error => + + if TC_Append_Test_Executed then + Report.Comment ("Constraint_Error correctly raised on " & + "attempted Append_File mode selection " & + "for a Direct_IO file"); + else + Report.Failed ("Append test was not executed"); + end if; + + when Incomplete => raise; + + when others => Report.Failed ("Unexpected exception raised"); + + end Change_File_Mode; + + Final_Block: + begin + if Dir_IO.Is_Open (Data_File) then + Dir_IO.Delete (Data_File); + else + Dir_IO.Open (Data_File, Dir_IO.In_File, Dir_Filename); + Dir_IO.Delete (Data_File); + end if; + exception + when others => + Report.Failed ("Delete not properly supported: Direct_IO"); + end Final_Block; + + exception + + -- Since Use_Error or Name_Error can be raised if, for the + -- specified mode, the environment does not support Direct_IO + -- operations, the following handlers are included: + + when Dir_IO.Name_Error => + Report.Not_Applicable("Name_Error raised on Direct IO Create"); + + when Dir_IO.Use_Error => + Report.Not_Applicable("Use_Error raised on Direct IO Create"); + + when others => + Report.Failed + ("Unexpected exception raised on Direct IO Create"); + + end Test_for_Direct_IO_Support; + + Report.Result; + +exception + when Incomplete => + Report.Result; + +end CXA8003; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa9001.a b/gcc/testsuite/ada/acats/tests/cxa/cxa9001.a new file mode 100644 index 000000000..4fe9c3576 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa9001.a @@ -0,0 +1,287 @@ +-- CXA9001.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 operations defined in the generic package +-- Ada.Storage_IO provide the ability to store and retrieve objects +-- which may include implicit levels of indirection in their +-- implementation, from an in-memory buffer. +-- +-- TEST DESCRIPTION: +-- The following scenario demonstrates how an object of a type with +-- (potential) levels of indirection (based on the implementation) +-- can be "flattened" and written/read to/from a Direct_IO file. +-- In this small example, we have attempted to simulate the situation +-- where two independent programs are using a particular Direct_IO file, +-- one writing data to the file, and the second program reading that file. +-- The Storage_IO Read and Write procedures are used to "flatten" +-- and reconstruct objects of the record type. +-- +-- APPLICABILITY CRITERIA: +-- Applicable to implementations capable of supporting external +-- Direct_IO files. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 07 Jun 95 SAIC Modified to constrain type used with Storage_IO. +-- 20 Nov 95 SAIC Corrected and enhanced for ACVC 2.0.1. +-- 25 Feb 97 PWB.CTA Allowed for non-support of some IO operations +--! + +with Report; +with Ada.Storage_IO; +with Ada.Direct_IO; + +procedure CXA9001 is + package Dir_IO is new Ada.Direct_IO (Integer); + Test_File : Dir_IO.File_Type; + Incomplete : exception; +begin + + Report.Test ("CXA9001", "Check that the operations defined in the " & + "generic package Ada.Storage_IO provide the " & + "ability to store and retrieve objects which " & + "may include implicit levels of indirection in " & + "their implementation, from an in-memory buffer"); + + + Test_For_Direct_IO_Support: + begin + + -- The following Create does not have any bearing on the test scenario, + -- but is included to check that the implementation supports Direct_IO + -- files. An exception on this Create statement will raise a Name_Error + -- or Use_Error, which will be handled to produce a Not_Applicable + -- result. If created, the file is immediately deleted, as it is not + -- needed for the program scenario. + + Dir_IO.Create (Test_File, Dir_IO.Out_File, Report.Legal_File_Name(1)); + + exception + + when Dir_IO.Use_Error | Dir_IO.Name_Error => + Report.Not_Applicable + ( "Files not supported - Create as Out_File for Direct_IO" ); + raise Incomplete; + + end Test_for_Direct_IO_Support; + + Deletion1: + begin + Dir_IO.Delete (Test_File); + exception + when others => + Report.Failed + ( "Delete not properly implemented for Direct_IO - 1" ); + end Deletion1; + + + Test_Block: + declare + + The_Filename : constant String := Report.Legal_File_Name(2); + + -- The following type is the basic unit used in this test. It is + -- incorporated into the definition of the Unit_Array_Type. + + type Unit_Type is + record + Position : Natural := 19; + String_Value : String (1..9) := (others => 'X'); + end record; + + TC_Size : Natural := Natural'First; + + procedure Data_Storage (Number_Of_Units : in Natural; + Result : out Natural) is + + -- Type based on input parameter. Uses type Unit_Type + -- as the array element. + type Unit_Array_Type is array (1..Number_Of_Units) + of Unit_Type; + + -- This type definition is the ultimate storage type used + -- in this test; uses type Unit_Array_Type as a record + -- component field. + -- This record type contains a component that is an array of + -- records, with each of these records containing a Natural + -- and a String value (i.e., a record containing an array of + -- records). + + type Data_Storage_Type is + record + Data_Value : Natural := Number_Of_Units; + Unit_Array : Unit_Array_Type; + end record; + + -- The instantiation of the following generic package is a + -- central point in this test. Storage_IO is instantiated for + -- a specific data type, and will be used to "flatten" objects + -- of that type into buffers. Direct_IO is instantiated for + -- these Storage_IO buffers. + + package Flat_Storage_IO is + new Ada.Storage_IO (Data_Storage_Type); + package Buffer_IO is + new Ada.Direct_IO (Flat_Storage_IO.Buffer_Type); + + Buffer_File : Buffer_IO.File_Type; + Outbound_Buffer : Flat_Storage_IO.Buffer_Type; + Storage_Item : Data_Storage_Type; + + begin -- procedure Data_Storage + + Buffer_IO.Create (Buffer_File, + Buffer_IO.Out_File, + The_Filename); + + Flat_Storage_IO.Write (Buffer => Outbound_Buffer, + Item => Storage_Item); + + -- At this point, any levels of indirection have been removed + -- by the Storage_IO procedure, and the buffered data can be + -- written to a file. + + Buffer_IO.Write (Buffer_File, Outbound_Buffer); + Buffer_IO.Close (Buffer_File); + Result := Storage_Item.Unit_Array'Last + -- 5 + + Storage_Item.Unit_Array -- 9 + (Storage_Item.Unit_Array'First).String_Value'Length; + + exception + when others => + Report.Failed ("Data storage error"); + if Buffer_IO.Is_Open (Buffer_File) then + Buffer_IO.Close (Buffer_File); + end if; + end Data_Storage; + + procedure Data_Retrieval (Number_Of_Units : in Natural; + Result : out Natural) is + type Unit_Array_Type is array (1..Number_Of_Units) + of Unit_Type; + + type Data_Storage_Type is + record + Data_Value : Natural := Number_Of_Units; + Unit_Array : Unit_Array_Type; + end record; + + package Flat_Storage_IO is + new Ada.Storage_IO (Data_Storage_Type); + package Reader_IO is + new Ada.Direct_IO (Flat_Storage_IO.Buffer_Type); + + Reader_File : Reader_IO.File_Type; + Inbound_Buffer : Flat_Storage_IO.Buffer_Type; + Storage_Item : Data_Storage_Type; + TC_Item : Data_Storage_Type; + + begin -- procedure Data_Retrieval + + Reader_IO.Open (Reader_File, Reader_IO.In_File, The_Filename); + Reader_IO.Read (Reader_File, Inbound_Buffer); + + Flat_Storage_IO.Read (Inbound_Buffer, Storage_Item); + + -- Validate the reconstructed value against an "unflattened" + -- value. + + if Storage_Item.Data_Value /= TC_Item.Data_Value + then + Report.Failed ("Data_Retrieval Error - 1"); + end if; + + for i in 1..Number_Of_Units loop + if Storage_Item.Unit_Array(i).String_Value'Length /= + TC_Item.Unit_Array(i).String_Value'Length or + Storage_Item.Unit_Array(i).Position /= + TC_Item.Unit_Array(i).Position or + Storage_Item.Unit_Array(i).String_Value /= + TC_Item.Unit_Array(i).String_Value + then + Report.Failed ("Data_Retrieval Error - 2"); + end if; + end loop; + + Result := Storage_Item.Unit_Array'Last + -- 5 + + Storage_Item.Unit_Array -- 9 + (Storage_Item.Unit_Array'First).String_Value'Length; + + if Reader_IO.Is_Open (Reader_File) then + Reader_IO.Delete (Reader_File); + else + Reader_IO.Open (Reader_File, + Reader_IO.In_File, + The_Filename); + Reader_IO.Delete (Reader_File); + end if; + + exception + when others => + Report.Failed ("Exception raised in Data_Retrieval"); + if Reader_IO.Is_Open (Reader_File) then + Reader_IO.Delete (Reader_File); + else + Reader_IO.Open (Reader_File, + Reader_IO.In_File, + The_Filename); + Reader_IO.Delete (Reader_File); + end if; + end Data_Retrieval; + + + begin -- Test_Block + + -- The number of Units is provided in this call to Data_Storage. + Data_Storage (Number_Of_Units => Natural(Report.Ident_Int(5)), + Result => TC_Size); + + if TC_Size /= 14 then + Report.Failed ("Data_Storage error in Data_Storage"); + end if; + + Data_Retrieval (Number_Of_Units => Natural(Report.Ident_Int(5)), + Result => TC_Size); + + if TC_Size /= 14 then + Report.Failed ("Data retrieval error in Data_Retrieval"); + end if; + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + +exception + when Incomplete => + Report.Result; + when others => + Report.Failed ( "Unexpected exception" ); + Report.Result; + +end CXA9001; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa9002.a b/gcc/testsuite/ada/acats/tests/cxa/cxa9002.a new file mode 100644 index 000000000..415a56630 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa9002.a @@ -0,0 +1,482 @@ +-- CXA9002.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 operations defined in the generic package +-- Ada.Storage_IO provide the ability to store and retrieve objects +-- of tagged types from in-memory buffers. +-- +-- TEST DESCRIPTION: +-- The following scenario demonstrates how objects of a tagged type, +-- extended types, and twice extended types can be written/read +-- to/from Direct_IO files. The Storage_IO subprograms, Read and Write, +-- demonstrated in this scenario, perform tag "fixing" prior to/following +-- transfer to the Direct_IO files. +-- This method is especially important for those implementations that +-- represent tags as pointers, or for cases where the tagged objects +-- are read in by a program other than the one that wrote them. +-- +-- In this small example, we have attempted to simulate the situation +-- where two independent programs are using a series of Direct_IO files, +-- one writing data to the files, and the second program reading the +-- data from those files. Two procedures are defined, the first +-- simulating the program responsible for writing, the second simulating +-- a separate program opening and reading the data from the files. +-- +-- The hierarchy of types used in this test can be displayed as follows: +-- +-- Account_Type +-- / \ +-- / \ +-- / \ +-- Cash_Account_Type Investment_Account_Type +-- / \ +-- / \ +-- / \ +-- Checking_Account_Type Savings_Account_Type +-- +-- APPLICABILITY CRITERIA: +-- Applicable to implementations capable of supporting external +-- Direct_IO files. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 08 Nov 95 SAIC Corrected incorrect prefix of 'Tag for ACVC 2.0.1, +-- and mode of files in Procedure Read_Data. +-- Added verification of objects reconstructed from +-- files. +-- 27 Feb 97 PWB.CTA Allowed for non-support of some IO operations +--! + +package CXA9002_0 is + + type Investment_Type is (Stocks, Bonds, Mutual_Funds); + type Savings_Type is (Standard, Business, Impound); + + type Account_Type is tagged + record + Num : String (1..3); + end record; + + type Cash_Account_Type is new Account_Type with + record + Years_As_Customer : Natural := 1; + end record; + + type Investment_Account_Type is new Account_Type with + record + Investment_Vehicle : Investment_Type := Stocks; + end record; + + type Checking_Account_Type is new Cash_Account_Type with + record + Checks_Per_Year : Positive := 200; + Interest_Bearing : Boolean := False; + end record; + + type Savings_Account_Type is new Cash_Account_Type with + record + Kind : Savings_Type := Standard; + end record; + +end CXA9002_0; + +--- + +with Report; +with Ada.Storage_IO; +with Ada.Direct_IO; +with Ada.Tags; +with CXA9002_0; + +procedure CXA9002 is + package Dir_IO is new Ada.Direct_IO (Integer); + Test_File : Dir_IO.File_Type; + Incomplete : exception; +begin + + Report.Test ("CXA9002", "Check that the operations defined in the " & + "generic package Ada.Storage_IO provide the " & + "ability to store and retrieve objects of " & + "tagged types from in-memory buffers"); + + + Test_For_Direct_IO_Support: + begin + + -- The following Create does not have any bearing on the test scenario, + -- but is included to check that the implementation supports Direct_IO + -- files. An exception on this Create statement will raise a Name_Error + -- or Use_Error, which will be handled to produce a Not_Applicable + -- result. If created, the file is immediately deleted, as it is not + -- needed for the program scenario. + + Dir_IO.Create (Test_File, + Dir_IO.Out_File, + Report.Legal_File_Name(1)); + exception + + when Dir_IO.Use_Error | Dir_IO.Name_Error => + Report.Not_Applicable + ( "Files not supported - Create as Out_File for Direct_IO" ); + raise Incomplete; + + end Test_for_Direct_IO_Support; + + Deletion: + begin + Dir_IO.Delete (Test_File); + exception + when others => + Report.Failed + ( "Delete not properly implemented for Direct_IO" ); + end Deletion; + + Test_Block: + declare + + use CXA9002_0; + + Acct_Filename : constant String := Report.Legal_File_Name(1); + Cash_Filename : constant String := Report.Legal_File_Name(2); + Inv_Filename : constant String := Report.Legal_File_Name(3); + Chk_Filename : constant String := Report.Legal_File_Name(4); + Sav_Filename : constant String := Report.Legal_File_Name(5); + + type Tag_Pointer_Type is access String; + + TC_Account_Type_Tag, + TC_Cash_Account_Type_Tag, + TC_Investment_Account_Type_Tag, + TC_Checking_Account_Type_Tag, + TC_Savings_Account_Type_Tag : Tag_Pointer_Type; + + TC_Account : Account_Type := + (Num => "123"); + + TC_Cash_Account : Cash_Account_Type := + (Num => "234", + Years_As_Customer => 3); + + TC_Investment_Account : Investment_Account_Type := + (Num => "456", + Investment_Vehicle => Bonds); + + TC_Checking_Account : Checking_Account_Type := + (Num => "567", + Years_As_Customer => 2, + Checks_Per_Year => 300, + Interest_Bearing => True); + + TC_Savings_Account : Savings_Account_Type := + (Num => "789", + Years_As_Customer => 14, + Kind => Business); + + procedure Buffer_Data is + + Account : Account_Type := + TC_Account; + Cash_Account : Cash_Account_Type := + TC_Cash_Account; + Investment_Account : Investment_Account_Type := + TC_Investment_Account; + Checking_Account : Checking_Account_Type := + TC_Checking_Account; + Savings_Account : Savings_Account_Type := + TC_Savings_Account; + + -- The instantiations below are a central point in this test. + -- Storage_IO is instantiated for each of the specific tagged + -- type. These instantiated packages will be used to compress + -- tagged objects of these various types into buffers that will + -- be written to the Direct_IO files declared below. + + package Acct_SIO is new Ada.Storage_IO (Account_Type); + package Cash_SIO is new Ada.Storage_IO (Cash_Account_Type); + package Inv_SIO is new Ada.Storage_IO (Investment_Account_Type); + package Chk_SIO is new Ada.Storage_IO (Checking_Account_Type); + package Sav_SIO is new Ada.Storage_IO (Savings_Account_Type); + + -- Direct_IO is instantiated for the buffer types defined in the + -- instantiated Storage_IO packages. + + package Acct_DIO is new Ada.Direct_IO (Acct_SIO.Buffer_Type); + package Cash_DIO is new Ada.Direct_IO (Cash_SIO.Buffer_Type); + package Inv_DIO is new Ada.Direct_IO (Inv_SIO.Buffer_Type); + package Chk_DIO is new Ada.Direct_IO (Chk_SIO.Buffer_Type); + package Sav_DIO is new Ada.Direct_IO (Sav_SIO.Buffer_Type); + + Acct_Buffer : Acct_SIO.Buffer_Type; + Cash_Buffer : Cash_SIO.Buffer_Type; + Inv_Buffer : Inv_SIO.Buffer_Type; + Chk_Buffer : Chk_SIO.Buffer_Type; + Sav_Buffer : Sav_SIO.Buffer_Type; + + Acct_File : Acct_DIO.File_Type; + Cash_File : Cash_DIO.File_Type; + Inv_File : Inv_DIO.File_Type; + Chk_File : Chk_DIO.File_Type; + Sav_File : Sav_DIO.File_Type; + + begin + + Acct_DIO.Create (Acct_File, Acct_DIO.Out_File, Acct_Filename); + Cash_DIO.Create (Cash_File, Cash_DIO.Out_File, Cash_Filename); + Inv_DIO.Create (Inv_File, Inv_DIO.Out_File, Inv_Filename); + Chk_DIO.Create (Chk_File, Chk_DIO.Out_File, Chk_Filename); + Sav_DIO.Create (Sav_File, Sav_DIO.Out_File, Sav_Filename); + + -- Store the tag values of the objects declared above for + -- comparison with tag values of objects following processing. + + TC_Account_Type_Tag := + new String'(Ada.Tags.External_Tag(Account_Type'Tag)); + + TC_Cash_Account_Type_Tag := + new String'(Ada.Tags.External_Tag(Cash_Account_Type'Tag)); + + TC_Investment_Account_Type_Tag := + new String'(Ada.Tags.External_Tag(Investment_Account_Type'Tag)); + + TC_Checking_Account_Type_Tag := + new String'(Ada.Tags.External_Tag(Checking_Account_Type'Tag)); + + TC_Savings_Account_Type_Tag := + new String'(Ada.Tags.External_Tag(Savings_Account_Type'Tag)); + + -- Prepare tagged data for writing to the Direct_IO files using + -- Storage_IO procedure to place data in buffers. + + Acct_SIO.Write (Buffer => Acct_Buffer, Item => Account); + Cash_SIO.Write (Cash_Buffer, Cash_Account); + Inv_SIO.Write (Inv_Buffer, Item => Investment_Account); + Chk_SIO.Write (Buffer => Chk_Buffer, Item => Checking_Account); + Sav_SIO.Write (Sav_Buffer, Savings_Account); + + -- At this point, the data and associated tag values have been + -- buffered by the Storage_IO procedure, and the buffered data + -- can be written to the appropriate Direct_IO file. + + Acct_DIO.Write (File => Acct_File, Item => Acct_Buffer); + Cash_DIO.Write (Cash_File, Cash_Buffer); + Inv_DIO.Write (Inv_File, Item => Inv_Buffer); + Chk_DIO.Write (File => Chk_File, Item =>Chk_Buffer); + Sav_DIO.Write (Sav_File, Sav_Buffer); + + -- Close all Direct_IO files. + + Acct_DIO.Close (Acct_File); + Cash_DIO.Close (Cash_File); + Inv_DIO.Close (Inv_File); + Chk_DIO.Close (Chk_File); + Sav_DIO.Close (Sav_File); + + exception + when others => Report.Failed("Exception raised in Buffer_Data"); + end Buffer_Data; + + procedure Read_Data is + + Account : Account_Type; + Cash_Account : Cash_Account_Type; + Investment_Account : Investment_Account_Type; + Checking_Account : Checking_Account_Type; + Savings_Account : Savings_Account_Type; + + -- Storage_IO is instantiated for each of the specific tagged + -- type. + + package Acct_SIO is new Ada.Storage_IO (Account_Type); + package Cash_SIO is new Ada.Storage_IO (Cash_Account_Type); + package Inv_SIO is new Ada.Storage_IO (Investment_Account_Type); + package Chk_SIO is new Ada.Storage_IO (Checking_Account_Type); + package Sav_SIO is new Ada.Storage_IO (Savings_Account_Type); + + -- Direct_IO is instantiated for the buffer types defined in the + -- instantiated Storage_IO packages. + + package Acct_DIO is new Ada.Direct_IO (Acct_SIO.Buffer_Type); + package Cash_DIO is new Ada.Direct_IO (Cash_SIO.Buffer_Type); + package Inv_DIO is new Ada.Direct_IO (Inv_SIO.Buffer_Type); + package Chk_DIO is new Ada.Direct_IO (Chk_SIO.Buffer_Type); + package Sav_DIO is new Ada.Direct_IO (Sav_SIO.Buffer_Type); + + Acct_Buffer : Acct_SIO.Buffer_Type; + Cash_Buffer : Cash_SIO.Buffer_Type; + Inv_Buffer : Inv_SIO.Buffer_Type; + Chk_Buffer : Chk_SIO.Buffer_Type; + Sav_Buffer : Sav_SIO.Buffer_Type; + + Acct_File : Acct_DIO.File_Type; + Cash_File : Cash_DIO.File_Type; + Inv_File : Inv_DIO.File_Type; + Chk_File : Chk_DIO.File_Type; + Sav_File : Sav_DIO.File_Type; + + begin + + -- Open the Direct_IO files. + + Acct_DIO.Open (Acct_File, Acct_DIO.In_File, Acct_Filename); + Cash_DIO.Open (Cash_File, Cash_DIO.In_File, Cash_Filename); + Inv_DIO.Open (Inv_File, Inv_DIO.In_File, Inv_Filename); + Chk_DIO.Open (Chk_File, Chk_DIO.In_File, Chk_Filename); + Sav_DIO.Open (Sav_File, Sav_DIO.In_File, Sav_Filename); + + -- Read the buffer data from the files using Direct_IO. + + Acct_DIO.Read (File => Acct_File, Item => Acct_Buffer); + Cash_DIO.Read (Cash_File, Cash_Buffer); + Inv_DIO.Read (Inv_File, Item => Inv_Buffer); + Chk_DIO.Read (File => Chk_File, Item =>Chk_Buffer); + Sav_DIO.Read (Sav_File, Sav_Buffer); + + -- At this point, the data and associated tag values are stored + -- in buffers. Use the Storage_IO procedure Read to recreate the + -- tagged objects from the buffers. + + Acct_SIO.Read (Buffer => Acct_Buffer, Item => Account); + Cash_SIO.Read (Cash_Buffer, Cash_Account); + Inv_SIO.Read (Inv_Buffer, Item => Investment_Account); + Chk_SIO.Read (Buffer => Chk_Buffer, Item => Checking_Account); + Sav_SIO.Read (Sav_Buffer, Savings_Account); + + -- Delete all Direct_IO files. + + Acct_DIO.Delete (Acct_File); + Cash_DIO.Delete (Cash_File); + Inv_DIO.Delete (Inv_File); + Chk_DIO.Delete (Chk_File); + Sav_DIO.Delete (Sav_File); + + Data_Verification_Block: + begin + + if Account /= TC_Account then + Report.Failed("Incorrect Account object reconstructed"); + end if; + + if Cash_Account /= TC_Cash_Account then + Report.Failed + ("Incorrect Cash_Account object reconstructed"); + end if; + + if Investment_Account /= TC_Investment_Account then + Report.Failed + ("Incorrect Investment_Account object reconstructed"); + end if; + + if Checking_Account /= TC_Checking_Account then + Report.Failed + ("Incorrect Checking_Account object reconstructed"); + end if; + + if Savings_Account /= TC_Savings_Account then + Report.Failed + ("Incorrect Savings_Account object reconstructed"); + end if; + + exception + when others => + Report.Failed + ("Exception raised during Data_Verification Block"); + end Data_Verification_Block; + + + -- To ensure that the tags of the values reconstructed by + -- Storage_IO were properly preserved, object tag values following + -- object reconstruction are compared with tag values of objects + -- stored prior to processing. + + Tag_Verification_Block: + begin + + if TC_Account_Type_Tag.all /= + Ada.Tags.External_Tag(Account_Type'Class(Account)'Tag) + then + Report.Failed("Incorrect Account tag"); + end if; + + if TC_Cash_Account_Type_Tag.all /= + Ada.Tags.External_Tag( + Cash_Account_Type'Class(Cash_Account)'Tag) + then + Report.Failed("Incorrect Cash_Account tag"); + end if; + + if TC_Investment_Account_Type_Tag.all /= + Ada.Tags.External_Tag( + Investment_Account_Type'Class(Investment_Account)'Tag) + then + Report.Failed("Incorrect Investment_Account tag"); + end if; + + if TC_Checking_Account_Type_Tag.all /= + Ada.Tags.External_Tag( + Checking_Account_Type'Class(Checking_Account)'Tag) + then + Report.Failed("Incorrect Checking_Account tag"); + end if; + + if TC_Savings_Account_Type_Tag.all /= + Ada.Tags.External_Tag( + Savings_Account_Type'Class(Savings_Account)'Tag) + then + Report.Failed("Incorrect Savings_Account tag"); + end if; + + exception + when others => + Report.Failed ("Exception raised during tag evaluation"); + end Tag_Verification_Block; + + exception + when others => Report.Failed ("Exception in Read_Data"); + end Read_Data; + + begin -- Test_Block + + -- Enter the data into the appropriate files. + Buffer_Data; + + -- Reconstruct the data from files, and verify the results. + Read_Data; + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + +exception + when Incomplete => + Report.Result; + when others => + Report.Failed ( "Unexpected exception" ); + Report.Result; + +end CXA9002; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa001.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa001.a new file mode 100644 index 000000000..6c2af9870 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxaa001.a @@ -0,0 +1,279 @@ +-- CXAA001.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 Line_Length and Page_Length maximums for a Text_IO +-- file of mode Append_File are initially zero (unbounded) after a +-- Create, Open, or Reset, and that these values can be modified using +-- the procedures Set_Line_Length and Set_Page_Length. +-- Check that setting the Line_Length and Page_Length attributes to zero +-- results in an unbounded Text_IO file. +-- Check that setting the line length when in Append_Mode doesn't +-- change the length of lines previously written to the Text_IO file. +-- +-- TEST DESCRIPTION: +-- This test attempts to simulate a possible text processing environment. +-- String values, from a number of different string types, are written to +-- a Text_IO file. Prior to the writing of each, the line length is set +-- to the particular length of the data being written. In addition, the +-- default line and page lengths are checked, to determine whether they +-- are unbounded (length = 0) following a create, reset, or open of a +-- Text_IO file with mode Append_File. +-- +-- APPLICABILITY CRITERIA: +-- This test is applicable only to implementations that support text +-- files. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 27 Feb 97 PWB.CTA Allowed for non-support of some IO operations +--! + +with Ada.Text_IO; +with Report; + +procedure CXAA001 is + use Ada; + Data_File : Text_IO.File_Type; + Data_Filename : constant String := + Report.Legal_File_Name ( Nam => "CXAA001" ); + Incomplete : exception; +begin + + Report.Test ("CXAA001","Check that the Line_Length and Page_Length " & + "maximums for a Text_IO file of mode Append_File " & + "are initially zero (unbounded) after a Create, " & + "Open, or Reset, and that these values can be " & + "modified using the procedures Set_Line_Length " & + "and Set_Page_Length"); + + Test_for_Text_IO_Support: + begin + + -- An implementation that does not support Text_IO in a particular + -- environment will raise Use_Error on calls to various + -- Text_IO operations. This block statement encloses a call to + -- Create, which should raise an exception in a non-supportive + -- environment. This exception will be handled to produce a + -- Not_Applicable result. + + Text_IO.Create (File => Data_File, + Mode => Text_IO.Append_File, + Name => Data_Filename); + + exception + + when Text_IO.Use_Error | Text_IO.Name_Error => + Report.Not_Applicable + ( "Files not supported - Create as Append_File for Text_IO" ); + raise Incomplete; + + end Test_for_Text_IO_Support; + + Operational_Test_Block: + declare + + subtype Confidential_Data_Type is string (1 .. 10); + subtype Secret_Data_Type is string (1 .. 20); + subtype Top_Secret_Data_Type is string (1 .. 30); + + Zero : constant Text_IO.Count := 0; + Confidential_Data_Size : constant Text_IO.Count := 10; + Secret_Data_Size : constant Text_IO.Count := 20; + Top_Secret_Data_Size : constant Text_IO.Count := 30; + + -- The following generic procedure is designed to simulate a text + -- processing environment where line and page sizes are set and + -- verified prior to the writing of data to a file. + + generic + Data_Size : Text_IO.Count; + procedure Write_Data_To_File (Data_Item : in String); + + procedure Write_Data_To_File (Data_Item : in String) is + use Text_IO; -- Used to provide visibility to the "/=" operator. + begin + if (Text_IO.Line_Length (Data_File) /= Zero) then -- Check default + Report.Failed("Line not of unbounded length"); -- line length, + elsif (Text_IO.Page_Length (Data_File) /= Zero) then -- default + Report.Failed ("Page not of unbounded length"); -- page length. + end if; + + Text_IO.Set_Line_Length (File => Data_File, -- Set the line + To => Data_Size); -- length. + Text_IO.Set_Page_Length (File => Data_File, -- Set the page + To => Data_Size); -- length. + -- Verify the lengths set. + if (Integer(Text_IO.Line_Length (Data_File)) /= + Report.Ident_Int(Integer(Data_Size))) then + Report.Failed ("Line length not set to appropriate length"); + elsif (Integer(Text_IO.Page_Length (Data_File)) /= + Report.Ident_Int(Integer(Data_Size))) then + Report.Failed ("Page length not set to appropriate length"); + end if; + + Text_IO.Put_Line (File => Data_File, -- Write data to + Item => Data_Item); -- file. + + end Write_Data_To_File; + + -- Instantiation for the three data types/sizes. + + procedure Write_Confidential_Data is + new Write_Data_To_File (Data_Size => Confidential_Data_Size); + + procedure Write_Secret_Data is + new Write_Data_To_File (Data_Size => Secret_Data_Size); + + procedure Write_Top_Secret_Data is + new Write_Data_To_File (Data_Size => Top_Secret_Data_Size); + + Confidential_Item : Confidential_Data_Type := "Confidenti"; + Secret_Item : Secret_Data_Type := "Secret Data Values "; + Top_Secret_Item : Top_Secret_Data_Type := + "Extremely Top Secret Data "; + + begin + + -- The following call simulates processing occurring after the create + -- of a Text_IO file with mode Append_File. + + Write_Confidential_Data (Confidential_Item); + + -- The following call simulates processing occurring after the reset + -- of a Text_IO file with mode Append_File. + + Reset1: + begin + Text_IO.Reset (Data_File, Text_IO.Append_File); -- Reset to + -- Append_File mode. + exception + when Text_IO.Use_Error => + Report.Not_Applicable + ( "Reset to Append_File not supported for Text_IO" ); + raise Incomplete; + end Reset1; + + Write_Secret_Data (Data_Item => Secret_Item); + + Text_IO.Close (Data_File); -- Close file. + + -- The following processing simulates processing occurring after the + -- opening of an existing file with mode Append_File. + + Text_IO.Open (Data_File, -- Open file in + Text_IO.Append_File, -- Append_File mode. + Data_Filename); + + Write_Top_Secret_Data (Top_Secret_Item); + + Test_Verification_Block: + declare + TC_String1, + TC_String2, + TC_String3 : String (1..80) := (others => ' '); + TC_Length1, + TC_Length2, + TC_Length3 : Natural := 0; + begin + + Reset2: + begin + Text_IO.Reset (Data_File, Text_IO.In_File); -- Reset for reading. + exception + when Text_IO.Use_Error => + Report.Not_Applicable + ( "Reset to In_File not supported for Text_IO" ); + raise Incomplete; + end Reset2; + + Text_IO.Get_Line (Data_File, TC_String1, TC_Length1); + Text_IO.Get_Line (Data_File, TC_String2, TC_Length2); + Text_IO.Get_Line (Data_File, TC_String3, TC_Length3); + + -- Verify that the line lengths of each line were accurate. + -- Note: Each data line was written to the file after the + -- particular line length had been set (to the data length). + + if not ((TC_Length1 = Natural(Confidential_Data_Size)) and + (TC_Length2 = Natural(Secret_Data_Size)) and + (TC_Length3 = Natural(Top_Secret_Data_Size))) then + Report.Failed ("Inaccurate line lengths read from file"); + end if; + + -- Verify that the data read from the file are accurate. + + if (TC_String1(1..TC_Length1) /= Confidential_Item) or else + (TC_String2(1..TC_Length2) /= Secret_Item) or else + (TC_String3(1..TC_Length3) /= Top_Secret_Item) then + Report.Failed ("Corrupted data items read from file"); + end if; + + exception + + when Incomplete => + raise; + + when others => + Report.Failed ("Error raised during data verification"); + + end Test_Verification_Block; + + exception + + when Incomplete => + raise; + + when others => + Report.Failed ("Exception raised during Text_IO processing"); + + end Operational_Test_Block; + + Deletion: + begin + -- Check that the file is open prior to deleting it. + if Text_IO.Is_Open(Data_File) then + Text_IO.Delete(Data_File); + else + Text_IO.Open(Data_File, Text_IO.In_File, Data_Filename); + Text_IO.Delete(Data_File); + end if; + exception + when others => + Report.Failed + ( "Delete not properly implemented for Text_IO" ); + end Deletion; + + Report.Result; + +exception + when Incomplete => + Report.Result; + when others => + Report.Failed ( "Unexpected exception" ); + Report.Result; + +end CXAA001; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa002.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa002.a new file mode 100644 index 000000000..953d33f1d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxaa002.a @@ -0,0 +1,257 @@ +-- CXAA002.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 procedures New_Page, Set_Line, Set_Col, and New_Line +-- subprograms perform properly on a text file created with mode +-- Append_File. +-- Check that the attributes Page, Line, and Column are all set to 1 +-- following the creation of a text file with mode Append_File. +-- Check that the functions Page, Line, and Col perform properly on a +-- text file created with mode Append_File. +-- Check that the procedures Put and Put_Line perform properly on text +-- files created with mode Append_File. +-- Check that the procedure Set_Line sets the current line number to +-- the value specified by the parameter "To" for text files created with +-- mode Append_File. +-- Check that the procedure Set_Col sets the current column number to +-- the value specified by the parameter "To" for text files created with +-- mode Append_File. +-- +-- TEST DESCRIPTION: +-- This test is designed to simulate the text processing that could +-- occur with files that have been created in Append_File mode. Various +-- calls to Text_IO formatting subprograms are called to properly +-- position text appended to a document. The text content and position +-- are subsequently verified for accuracy. +-- +-- APPLICABILITY CRITERIA: +-- This test is applicable only to implementations that support text +-- files. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 27 Feb 97 PWB.CTA Allowed for non-support of some IO operations + +--! + +with Ada.Text_IO; +with Report; + +procedure CXAA002 is + use Ada; + Data_File : Text_IO.File_Type; + Data_Filename : constant String := + Report.Legal_File_Name ( Nam => "CXAA002" ); + Incomplete : exception; +begin + + Report.Test ("CXAA002", "Check that page, line, and column formatting " & + "subprograms perform properly on text files " & + "created with mode Append_File"); + + Test_for_Text_IO_Support: + begin + + -- An implementation that does not support Text_IO in a particular + -- environment will raise Use_Error on calls to various + -- Text_IO operations. This block statement encloses a call to + -- Create, which should raise the exception in a non-supportive + -- environment. This exception will be handled to produce a + -- Not_Applicable result. + + Text_IO.Create (File => Data_File, + Mode => Text_IO.Append_File, + Name => Data_Filename); + + exception + + when Text_IO.Use_Error | Text_IO.Name_Error => + Report.Not_Applicable + ( "Files not supported - Create as Append_File for Text_IO" ); + raise Incomplete; + + end Test_for_Text_IO_Support; + + Operational_Test_Block: + declare + Default_Position : constant Text_IO.Positive_Count := 1; + Section_Header : constant String := "VII. "; + Appendix_Title : constant String := "Appendix A"; + Appendix_Content : constant String := "TBD"; + + -- The following procedure simulates the addition of an Appendix page + -- to an existing text file. + procedure Position_Appendix_Text is + use Text_IO; -- To provide visibility to the "/=" operator. + begin + + -- Test control code. + -- Verify initial page, line, column number. + if "/="(Text_IO.Page (Data_File), Default_Position) then + Report.Failed ("Incorrect default page number"); + end if; + if Text_IO.Line (Data_File) /= Default_Position then + Report.Failed ("Incorrect default line number"); + end if; + if "/="(Text_IO.Col (Data_File), Default_Position) then + Report.Failed ("Incorrect default column number"); + end if; + + -- Simulated usage code. + -- Set new page/line positions. + Text_IO.Put_Line + (Data_File, "Add some optional data to the file here"); + Text_IO.New_Page (Data_File); + Text_IO.New_Line (File => Data_File, Spacing => 2); + + -- Test control code. + if Integer(Text_IO.Page (Data_File)) /= Report.Ident_Int(2) or else + Integer(Text_IO.Line (Data_File)) /= Report.Ident_Int(3) then + Report.Failed ("Incorrect results from page/line positioning"); + end if; + + -- Simulated usage code. + Text_IO.Put (Data_File, Section_Header); -- Position title + Text_IO.Put_Line (Data_File, Appendix_Title); -- of Appendix. + + Text_IO.Set_Line (File => Data_File, To => 5); -- Set new + Text_IO.Set_Col (File => Data_File, To => 8); -- position. + + -- Test control code. + if (Integer(Text_IO.Line (Data_File)) /= Report.Ident_Int(5)) or + (Integer(Text_IO.Col (Data_File)) /= Report.Ident_Int(8)) then + Report.Failed ("Incorrect results from line/column positioning"); + end if; + + -- Simulated usage code. -- Position + Text_IO.Put_Line (Data_File, Appendix_Content); -- content of + -- Appendix. + end Position_Appendix_Text; + + begin + + -- This code section simulates a scenario that could occur in a + -- text processing environment: + -- A document is created/modified/edited Then... + -- Text is to be appended to the document. + -- A procedure is called to perform that operation. + -- The position on the appended page is set, verified, and text is + -- appended to the existing file. + -- + -- Note: The text file has been originally created in Append_File + -- mode, and has not been closed prior to this processing. + + Position_Appendix_Text; + + Test_Verification_Block: + declare + TC_Page, + TC_Line, + TC_Column : Text_IO.Positive_Count; + TC_Position : Natural := 0; + Blanks : constant String := " "; + TC_String : String (1 .. 17) := Blanks; + begin + + Reset1: + begin + Text_IO.Reset (Data_File, Text_IO.In_File); + exception + when Text_IO.Use_Error => + Report.Not_Applicable + ( "Reset to In_File not supported for Text_IO" ); + raise Incomplete; + end Reset1; + + Text_IO.Skip_Page (Data_File); + -- Loop to the third line + for I in 1 .. 3 loop -- and read the contents. + Text_IO.Get_Line (Data_File, TC_String, TC_Position); + end loop; + + if (TC_Position /= 16) or else -- Verify the title line. + (TC_String (1..4) /= "VII.") or else + (TC_String (3..16) /= ("I. " & Appendix_Title)) then + Report.Failed ("Incorrect positioning of title line"); + end if; + + TC_String := Blanks; -- Clear string. + -- Loop to the fifth line + for I in 4 .. 5 loop -- and read the contents. + Text_IO.Get_Line (Data_File, TC_String, TC_Position); + end loop; + + if (TC_Position /= 10) or -- Verify the contents. + (TC_String (8..10) /= Appendix_Content) then + Report.Failed ("Incorrect positioning of contents line"); + end if; + + exception + + when Incomplete => + raise; + + when others => + Report.Failed ("Error raised during data verification"); + + end Test_Verification_Block; + + exception + + when Incomplete => + raise; + + when others => + Report.Failed ("Exception raised during Text_IO processing"); + + end Operational_Test_Block; + + Deletion: + begin + -- Delete the external file. + if Text_IO.Is_Open(Data_File) then + Text_IO.Delete(Data_File); + else + Text_IO.Open(Data_File, Text_IO.In_File, Data_Filename); + Text_IO.Delete(Data_File); + end if; + exception + when others => + Report.Failed + ( "Delete not properly implemented for Text_IO" ); + end Deletion; + + Report.Result; + +exception + when Incomplete => + Report.Result; + when others => + Report.Failed ( "Unexpected exception" ); + Report.Result; + +end CXAA002; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa003.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa003.a new file mode 100644 index 000000000..c9580dfb3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxaa003.a @@ -0,0 +1,293 @@ +-- CXAA003.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 procedures New_Page, Set_Line, Set_Col, and New_Line +-- subprograms perform properly on a text file reset (from Out_File) +-- with mode Append_File. +-- Check that the attributes Page, Line, and Column are all set to 1 +-- following the reset of a text file with mode Append_File. +-- Check that the functions Page, Line, and Col perform properly on a +-- text file reset with mode Append_File. +-- Check that the procedures Put and Put_Line perform properly on text +-- files reset with mode Append_File. +-- Check that the procedure Set_Line sets the current line number to +-- the value specified by the parameter "To" for text files reset with +-- mode Append_File. Check that Set_Line has no effect if the specified +-- line equals the current line. +-- Check that the procedure Set_Col sets the current column number to +-- the value specified by the parameter "To" for text files reset with +-- mode Append_File. +-- +-- TEST DESCRIPTION: +-- This test is designed to simulate the text processing that could +-- occur with files that have been created in Out_File mode, +-- and then reset to Append_File mode. +-- Various calls to Text_IO formatting subprograms are called to properly +-- position text appended to a document. The text content and position +-- are subsequently verified for accuracy. +-- +-- APPLICABILITY CRITERIA: +-- This test is applicable only to implementations that support text +-- files. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 24 Feb 97 PWB.CTA Allowed for non-support of some IO operations. +--! + +with Ada.Text_IO; +with Report; + +procedure CXAA003 is + use Ada; + Data_File : Text_IO.File_Type; + Data_Filename : constant String := + Report.Legal_File_Name ( Nam => "CXAA003" ); + Incomplete : exception; + +begin + + Report.Test ("CXAA003", "Check that page, line, and column formatting " & + "subprograms perform properly on text files " & + "reset with mode Append_File"); + + Test_for_Text_IO_Support: + begin + + -- An implementation that does not support Text_IO in a particular + -- environment will raise Use_Error on calls to various + -- Text_IO operations. This block statement encloses a call to + -- Create, which should raise the exception in a non-supportive + -- environment. This exception will be handled to produce a + -- Not_Applicable result. + + Text_IO.Create (File => Data_File, + Mode => Text_IO.Out_File, + Name => Data_Filename); + exception + when Text_IO.Use_Error | Text_IO.Name_Error => + Report.Not_Applicable + ( "Text files not supported - Create as Out_File" ); + raise Incomplete; + end Test_for_Text_IO_Support; + + Operational_Test_Block: + declare + + Default_Position : constant Text_IO.Positive_Count := 1; + + Section_Header : constant String := "IX. "; + Glossary_Title : constant String := "GLOSSARY"; + Glossary_Content : constant String := "TBD"; + + -- The following procedure simulates the addition of a Glossary page + -- to an existing text file that has been reset with mode + -- Append_File. + + procedure Position_Glossary_Text + (The_File : in out Text_IO.File_Type) is + use Text_IO; -- To provide visibility to the "/=" operator. + begin + + -- Test control code. + -- Verify initial page value. + if (Text_IO.Page (The_File) /= Default_Position) then + Report.Failed ("Incorrect default page number"); + end if; + -- Verify initial line number. + if (Text_IO.Line (The_File) /= Default_Position) then + Report.Failed ("Incorrect default line number"); + end if; + -- Verify initial column number. + if (Text_IO.Col (The_File) /= Default_Position) then + Report.Failed ("Incorrect default column number"); + end if; + -- Simulated usage code. Set new page/line positions. + Text_IO.New_Page (The_File); + Text_IO.New_Page (The_File); + Text_IO.New_Line (File => The_File, Spacing => 1); + + -- Test control code. + if (Integer(Text_IO.Page(The_File)) /= + Report.Ident_Int(3)) or else + (Integer(Text_IO.Line (The_File)) /= + Report.Ident_Int(2)) then + Report.Failed ("Incorrect results from page/line positioning"); + end if; + + -- Simulated usage code. Position title of Glossary. + Text_IO.Put (The_File, Section_Header); + Text_IO.Put_Line (The_File, Glossary_Title); + -- Set line to the current line. + Text_IO.Set_Line (File => The_File, To => 3); + + -- Test control code. + if (Integer(Text_IO.Page (The_File)) /= Report.Ident_Int(3)) or + (Integer(Text_IO.Line (The_File)) /= Report.Ident_Int(3)) or + (Integer(Text_IO.Col (The_File)) /= Report.Ident_Int(1)) then + Report.Failed ("Set_Line failed for current line"); + end if; + + -- Simulated usage code. + Text_IO.Set_Line (File => The_File, To => 4); -- Set new + Text_IO.Set_Col (File => The_File, To => 10); -- position. + + -- Test control code. + if (Integer(Text_IO.Line (The_File)) /= Report.Ident_Int(4)) or + (Integer(Text_IO.Col (The_File)) /= Report.Ident_Int(10)) then + Report.Failed + ("Incorrect results from line/column positioning"); + end if; + + -- Simulated usage code. -- Position + Text_IO.Put_Line (The_File, Glossary_Content); -- content of + -- Glossary. + end Position_Glossary_Text; + + + begin + + -- In the scenario, data is added to the file here. + Text_IO.Put_Line (File => Data_File, Item => "Some optional data"); + + -- This code section simulates a scenario that could occur in a + -- text processing environment. Text is to be appended to an + -- existing document: + -- The file is reset to append mode. + -- A procedure is called to perform the positioning and placement + -- of text. + -- The position on the appended page is set, verified, and text is + -- placed in the file. + -- + -- Note: The text file has been originally created in Out_File + -- mode, and has subsequently been reset to Append_File mode. + + Reset1: + begin + -- Reset has effect of calling New_Page. + Text_IO.Reset (Data_File, Text_IO.Append_File); + exception + when Text_IO.Use_Error => + Report.Not_Applicable + ( "Reset to Append_File not supported for Text_IO" ); + raise Incomplete; + end Reset1; + + Position_Glossary_Text (The_File => Data_File); + + Test_Verification_Block: + declare + TC_Page, TC_Line, TC_Column : Text_IO.Positive_Count; + TC_Position : Natural := 0; + Blanks : constant String := + " "; + TC_String : String (1 .. 15) := Blanks; + begin + Reset2: + begin + Text_IO.Reset (Data_File, Text_IO.In_File); + exception + when Text_IO.Use_Error => + Report.Not_Applicable + ( "Reset to In_File not supported for Text_IO" ); + raise Incomplete; + end Reset2; + + Text_IO.Skip_Page (Data_File); + Text_IO.Skip_Page (Data_File); + + -- If the Reset to Append_File mode actually put a page terminator + -- on the file, as allowed (but not required) by RM A.10.2(4), then + -- we are now on page 3, an empty page. We'll need to skip one more. + + if Text_IO.End_Of_Page (Data_File) then + Text_IO.Skip_Page (Data_File); + end if; + + -- Now we're on the Glossary page. + + -- Loop to the second line + for I in 1 .. 2 loop -- and read the contents. + Text_IO.Get_Line (Data_File, TC_String, TC_Position); + end loop; + if (TC_Position /= 13) or else -- Verify the title line. + (TC_String (1..2) /= "IX") or else + (TC_String (3..13) /= (". " & Glossary_Title)) then + Report.Failed ("Incorrect positioning of title line"); + end if; + + TC_String := Blanks; -- Clear string. + -- Loop to the fourth line + for I in 3 .. 4 loop -- and read the contents. + Text_IO.Get_Line (Data_File, TC_String, TC_Position); + end loop; + + if (TC_Position /= 12) or -- Verify the contents. + (TC_String (8..12) /= " " & Glossary_Content) then + Report.Failed ("Incorrect positioning of contents line"); + end if; + + exception + when Incomplete => + raise; + when others => + Report.Failed ("Error raised during data verification"); + + end Test_Verification_Block; + + exception + when Incomplete => + raise; + when others => + Report.Failed ("Exception raised during Text_IO processing"); + + end Operational_Test_Block; + + Final_Block: + begin + -- Delete the external file. + if Text_IO.Is_Open (Data_File) then + Text_IO.Delete (Data_File); + else + Text_IO.Open (Data_File, Text_IO.In_File, Data_Filename); + Text_IO.Delete (Data_File); + end if; + exception + when others => + Report.Failed ( "Delete not properly implemented for Text_IO" ); + end Final_Block; + + Report.Result; + + exception + when Incomplete => + Report.Result; + when others => + Report.Failed ( "Unexpected exception" ); + Report.Result; + +end CXAA003; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa004.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa004.a new file mode 100644 index 000000000..f3ea17eba --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxaa004.a @@ -0,0 +1,260 @@ +-- CXAA004.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 procedures New_Page, Set_Line, Set_Col, and New_Line +-- perform properly on a text file opened with mode Append_File. +-- Check that the attributes Page, Line, and Column are all set to 1 +-- following the opening of a text file with mode Append_File. +-- Check that the functions Page, Line, and Col perform properly on a +-- text file opened with mode Append_File. +-- Check that the procedures Put and Put_Line perform properly on text +-- files opened with mode Append_File. +-- Check that the procedure Set_Line sets the current line number to +-- the value specified by the parameter "To" for text files opened with +-- mode Append_File. +-- Check that the procedure Set_Col sets the current column number to +-- the value specified by the parameter "To" for text files reset with +-- mode Append_File. +-- +-- TEST DESCRIPTION: +-- This test is designed to simulate the text processing that could +-- occur with files that have been created in Out_File mode, +-- and then reset to Append_File mode. +-- Various calls to Text_IO formatting subprograms are called to properly +-- position text appended to a document. The text content and position +-- are subsequently verified for accuracy. +-- +-- APPLICABILITY CRITERIA: +-- This test is applicable only to implementations that support text +-- files. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 24 Feb 97 PWB.CTA Allowed for non-support of some IO operations. +--! + +with Ada.Text_IO; +with Report; + +procedure CXAA004 is + use Ada; + Data_File : Text_IO.File_Type; + Data_Filename : constant String := + Report.Legal_File_Name ( Nam => "CXAA004" ); + Incomplete : exception; + +begin + + Report.Test ("CXAA004", "Check that page, line, and column formatting " & + "subprograms perform properly on text files " & + "opened with mode Append_File"); + + Test_for_Text_IO_Support: + begin + + -- An implementation that does not support Text_IO in a particular + -- environment will raise Use_Error on calls to various + -- Text_IO operations. This block statement encloses a call to + -- Create, which should raise the exception in a non-supportive + -- environment. This exception will be handled to produce a + -- Not_Applicable result. + + Text_IO.Create (File => Data_File, + Mode => Text_IO.Out_File, + Name => Data_Filename); + + exception + when Text_IO.Use_Error | Text_IO.Name_Error => + Report.Not_Applicable + ( "Files not supported - Create for Text_IO" ); + raise Incomplete; + end Test_for_Text_IO_Support; + + Operational_Test_Block: + declare + use Text_IO; -- To provide visibility to the "/=" operator. + + Default_Position : constant Text_IO.Positive_Count := 1; + + Section_Header : constant String := "X. "; + Reference_Title : constant String := "REFERENCES"; + Reference_Content : constant String := "Available Upon Request"; + + begin + + -- Some amount of text processing would occur here in the scenario + -- following file creation, prior to file closure. + Text_IO.Put_Line (File => Data_File, Item => "Some optional data"); + + -- Close has the effect of a call to New_Page (adding a page + -- terminator). + Text_IO.Close (Data_File); + + -- This code section simulates a scenario that could occur in a + -- text processing environment: + -- Certain text is to be appended to a document. + -- The file is opened in Append_File mode. + -- The position on the appended page is set, verified, and text + -- is placed in the file. + -- + -- Note: The text file has been originally created in Out_File + -- mode, has been subsequently closed and is now being reopened in + -- Append_File mode for further processing. + + Text_IO.Open (Data_File, Text_IO.Append_File, Data_Filename); + + -- Test control code. + if (Text_IO.Page(Data_File) /= Default_Position) then -- Verify init. + Report.Failed ("Incorrect default page number"); -- page value. + end if; + if (Text_IO.Line(Data_File) /= Default_Position) then -- Verify init. + Report.Failed ("Incorrect default line number"); -- line number. + end if; + if (Text_IO.Col (Data_File) /= Default_Position) then -- Verify init. + Report.Failed ("Incorrect default column number"); -- column no. + end if; + + -- Simulated usage code. + Text_IO.New_Page (Data_File); -- Set new page/ + Text_IO.New_Line (File => Data_File, Spacing => 2); -- line pos. + Text_IO.Put (Data_File, Section_Header); -- Position + Text_IO.Put_Line (Data_File, Reference_Title); -- title. + + -- Test control code. -- Verify new + if (Integer(Text_IO.Page (Data_File)) /= -- page and + Report.Ident_Int(2)) or else -- line. + (Integer(Text_IO.Line (Data_File)) /= + Report.Ident_Int(4)) then + Report.Failed ("Incorrect results from page/line positioning"); + end if; + + -- Simulated usage code. + Text_IO.Set_Line (File => Data_File, To => 8); -- Set new + Text_IO.Set_Col (File => Data_File, To => 30); -- position. + Text_IO.Put_Line (Data_File, Reference_Content); + + -- Test control code. + if (Integer(Text_IO.Line (Data_File)) /= + Report.Ident_Int(9)) or -- Verify new + (Integer(Text_IO.Col (Data_File)) /= -- position. + Report.Ident_Int(1)) then + Report.Failed ("Incorrect results from line/column positioning"); + end if; + + Test_Verification_Block: + declare + TC_Page, TC_Line, TC_Column : Text_IO.Positive_Count; + TC_Position : Natural := 0; + TC_String : String (1 .. 55) := (others => ' '); + begin + + Reset1: + begin + Text_IO.Reset (Data_File, Text_IO.In_File); + exception + when Text_IO.Use_Error => + Report.Not_Applicable + ( "Reset to In_File not supported for Text_IO" ); + raise Incomplete; + end Reset1; + + Text_IO.Skip_Page (Data_File); + + -- If the Reset to Append_File mode actually put a page terminator + -- in the file, as allowed (but not required) by RM A.10.2(4), then + -- we are now on page 2, an empty page. Therefore, we need to skip + -- one more page. + + if Text_IO.End_Of_Page (Data_File) then + Text_IO.Skip_Page (Data_File); + end if; + + -- Now we're on the reference page. + + -- Loop to the third line + for I in 1 .. 3 loop -- and read the contents. + Text_IO.Get_Line (Data_File, TC_String, TC_Position); + end loop; + + if (TC_Position /= 14) or else -- Verify the title line. + (TC_String (1..6) /= "X. RE") or else + (TC_String (2..14) /= (". " & Reference_Title)) then + Report.Failed ("Incorrect positioning of title line"); + end if; + -- Loop to the eighth line + for I in 4 .. 8 loop -- and read the contents. + Text_IO.Get_Line (Data_File, TC_String, TC_Position); + end loop; + + if (TC_Position /= 51) or -- Verify the contents. + (TC_String (30..51) /= "Available Upon Request") then + Report.Failed ("Incorrect positioning of contents line"); + end if; + + exception + + when Incomplete => + raise; + when others => + Report.Failed ("Error raised during data verification"); + + end Test_Verification_Block; + + exception + + when Incomplete => + raise; + when others => + Report.Failed ("Exception raised during Text_IO processing"); + + end Operational_Test_Block; + + Final_Block: + begin + -- Delete the external file. + if Text_IO.Is_Open (Data_File) then + Text_IO.Delete (Data_File); + else + Text_IO.Open (Data_File, Text_IO.In_File, Data_Filename); + Text_IO.Delete (Data_File); + end if; + exception + when others => + Report.Failed ( "Delete not properly implemented - Text_IO" ); + end Final_Block; + + Report.Result; + +exception + + when Incomplete => + Report.Result; + when others => + Report.Failed ("Unexpected exception"); + Report.Result; + +end CXAA004; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa005.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa005.a new file mode 100644 index 000000000..7b2a0bc39 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxaa005.a @@ -0,0 +1,292 @@ +-- CXAA005.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 Put, when called with string parameters, does +-- not update the line number of a text file of mode Append_File, when +-- the line length is unbounded (i.e., only the column number is +-- updated). +-- Check that a call to the procedure Put with a null string argument +-- has no measurable effect on a text file of mode Append_File. +-- +-- TEST DESCRIPTION: +-- This test is designed to ensure that when a string is appended to an +-- unbounded text file, it is placed following the last element currently +-- in the file. For an unbounded text file written with Put procedures +-- only (not Put_Line), the line number should not be incremented by +-- subsequent calls to Put in Append_File mode. Only the column number +-- should be incremented based on the length of the string parameter +-- placed in the file. If a call to Put with a null string argument is +-- made, no change to the line or column number should occur, and no +-- element(s) should be added to the file, so that there would be no +-- measurable change to the file. +-- +-- APPLICABILITY CRITERIA: +-- This test is applicable to all implementations that support Text_IO +-- processing and external files. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 24 Feb 97 CTA.PWB Allowed for non-support of some IO operations. +--! + +with Ada.Text_IO; +with Report; + +procedure CXAA005 is + An_Unbounded_File : Ada.Text_IO.File_Type; + Unbounded_File_Name : constant String := + Report.Legal_File_Name ( Nam => "CXAA005" ); + Incomplete : exception; + +begin + + Report.Test ("CXAA005", "Check that the procedure Put does not " & + "increment line numbers when used with " & + "unbounded text files of mode Append_File"); + + Test_for_Text_IO_Support: + begin + + -- An application creates a text file in mode Out_File, with the intention + -- of entering string data packets into the file as appropriate. In the + -- event that the particular environment where the application is running + -- does not support Text_IO, Use_Error will be raised on calls to Text_IO + -- operations. + -- This exception will be handled to produce a Not_Applicable result. + + Ada.Text_IO.Create (File => An_Unbounded_File, + Mode => Ada.Text_IO.Out_File, + Name => Unbounded_File_Name); + exception + when Ada.Text_IO.Use_Error | Ada.Text_IO.Name_Error => + Report.Not_Applicable + ( "Files not supported - Create for Text_IO" ); + raise Incomplete; + end Test_For_Text_IO_Support; + + Operational_Test_Block: + declare + subtype String_Sequence_Type is string (1 .. 20); + type String_Pointer_Type is access String_Sequence_Type; + +-- During the course of processing, the application creates a variety of data +-- pointers that refer to particular data items. The possibility of having +-- null data values in this environment exists. + + Data_Packet_1 : String_Pointer_Type := + new String_Sequence_Type'("One Data Sequence 01"); + + Data_Packet_2 : String_Pointer_Type := + new String_Sequence_Type'("New Data Sequence 02"); + + Blank_Data_Packet : String_Pointer_Type := + new String_Sequence_Type'(" "); + + Null_Data_Packet : constant String := ""; + + TC_Line, TC_Col : Natural := 0; + + function TC_Mode_Selection (Selector : Integer) + return Ada.Text_IO.File_Mode is + begin + case Selector is + when 1 => return Ada.Text_IO.In_File; + when 2 => return Ada.Text_IO.Out_File; + when others => return Ada.Text_IO.Append_File; + end case; + end TC_Mode_Selection; + + begin + +-- The application places some data into the file, using the Put subroutine. +-- This operation can occur one-to-many times. + + Ada.Text_IO.Put (An_Unbounded_File, Data_Packet_1.all); + + -- Test control code. + if (Integer(Ada.Text_IO.Col (An_Unbounded_File)) /= + Report.Ident_Int(21)) or + (Integer(Ada.Text_IO.Line (An_Unbounded_File)) /= + Report.Ident_Int(1)) then + Report.Failed ("Incorrect Col position after 1st Put"); + end if; + +-- The application may close the file at some point following its initial +-- entry of data. + + Ada.Text_IO.Close (An_Unbounded_File); + +-- At some later point in the processing, more data needs to be added to the +-- file, so the application opens the file in Append_File mode. + + Ada.Text_IO.Open (File => An_Unbounded_File, + Mode => Ada.Text_IO.Append_File, + Name => Unbounded_File_Name); + + -- Test control code. + -- Store line/column number for later comparison. + TC_Line := Natural(Ada.Text_IO.Line(An_Unbounded_File)); + TC_Col := Natural(Ada.Text_IO.Col(An_Unbounded_File)); + +-- Additional data items can then be appended to the file. + + Ada.Text_IO.Put (An_Unbounded_File, Blank_Data_Packet.all); + + -- Test control code. + if (Natural(Ada.Text_IO.Col (An_Unbounded_File)) /= + (TC_Col + 20)) or + (Natural(Ada.Text_IO.Line (An_Unbounded_File)) /= + TC_Line) then + Report.Failed ("Incorrect Col position after 2nd Put"); + end if; + +-- In order to accommodate various scenarios, the application may have changed +-- the mode of the data file to In_File in order to retrieve/verify some of +-- the data contained there. However, with the need to place more data into +-- the file, the file can be reset to Append_File mode. + + Reset1: + begin + Ada.Text_IO.Reset (An_Unbounded_File, + TC_Mode_Selection (Report.Ident_Int(3))); + exception + when Ada.Text_IO.Use_Error => + Report.Not_Applicable + ( "Reset to Append_File not supported for Text_IO" ); + raise Incomplete; + end Reset1; + + -- Test control code. + -- Store line/column number for later comparison. + TC_Line := Natural(Ada.Text_IO.Line(An_Unbounded_File)); + TC_Col := Natural(Ada.Text_IO.Col(An_Unbounded_File)); + +-- Additional data can then be appended to the file. On some occasions, an +-- attempt to enter a null string value into the file may occur. This should +-- have no effect on the file, leaving it unchanged. + + -- No measurable effect from Put with null string. + Ada.Text_IO.Put (An_Unbounded_File, Null_Data_Packet); + + -- Test control code. + -- There should be no change following the Put above. + if (Natural(Ada.Text_IO.Col (An_Unbounded_File)) /= + TC_Col) or + (Natural(Ada.Text_IO.Line (An_Unbounded_File)) /= + TC_Line) then + Report.Failed ("Incorrect Col position after 3rd Put"); + end if; + +-- Additional data can be appended to the file. + + Ada.Text_IO.Put (An_Unbounded_File, Data_Packet_2.all); + + -- Test control code. + if (Natural(Ada.Text_IO.Col (An_Unbounded_File)) /= + (TC_Col + 20)) or + (Integer(Ada.Text_IO.Line (An_Unbounded_File)) /= + TC_Line) then + Report.Failed ("Incorrect Col position after 4th Put"); + end if; + + Test_Verification_Block: + declare + File_Data : String (1 .. 80); + TC_Width : Natural; + begin + +-- The application has the capability to reset the file to In_File mode to +-- verify some of the data that is contained there. + + Reset2: + begin + Ada.Text_IO.Reset (An_Unbounded_File, Ada.Text_IO.In_File); + exception + when Ada.Text_IO.Use_Error => + Report.Not_Applicable + ( "Reset to In_File not supported - Text_IO" ); + raise Incomplete; + end Reset2; + + Ada.Text_IO.Get_Line (An_Unbounded_File, + File_Data, + TC_Width); + + -- Test control code. + -- Since it is implementation defined whether a page + -- terminator separates preexisting text from new text + -- following an open in append mode (as occurred above), + -- verify only that the first data item written to the + -- file was not overwritten by any subsequent call to Put. + + if (File_Data (File_Data'First) /= 'O') or + (File_Data (20) /= '1') then + Report.Failed ("Data placed incorrectly in file"); + end if; + + exception + when Incomplete => + raise; + when others => + Report.Failed ("Error raised during data verification"); + end Test_Verification_Block; + + exception + when Incomplete => + raise; + when others => + Report.Failed ("Exception in Text_IO processing"); + end Operational_Test_Block; + + Final_Block: + begin + -- Delete the external file. + if Ada.Text_IO.Is_Open(An_Unbounded_File) then + Ada.Text_IO.Delete (An_Unbounded_File); + else + Ada.Text_IO.Open(An_Unbounded_File, + Ada.Text_IO.In_File, + Unbounded_File_Name); + Ada.Text_IO.Delete (An_Unbounded_File); + end if; + exception + when others => + Report.Failed + ( "Delete not properly implemented -- Text_IO" ); + end Final_Block; + + Report.Result; + +exception + + when Incomplete => + Report.Result; + when others => + Report.Failed ( "Unexpected exception" ); + Report.Result; + +end CXAA005; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa006.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa006.a new file mode 100644 index 000000000..518d43b89 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxaa006.a @@ -0,0 +1,285 @@ +-- CXAA006.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 for a bounded line length text file of mode Append_File, +-- when the number of characters to be output exceeds the number of +-- columns remaining on the current line, a call to Put will output +-- characters of the string sufficient to fill the remaining columns of +-- the line (up to line length), then output a line terminator, reset the +-- column number, increment the line number, then output the balance of +-- the item. +-- +-- Check that the procedure Put does not raise Layout_Error when the +-- number of characters to be output exceeds the line length of a bounded +-- text file of mode Append_File. +-- +-- TEST DESCRIPTION: +-- This test demonstrates the situation where an application intends to +-- output variable length string elements to a text file in the most +-- efficient manner possible. This is the case in a typesetting +-- environment where text is compressed and split between lines of a +-- bounded length. +-- +-- The procedure Put will break string parameters placed in the file at +-- the point of the line length. Two examples are demonstrated in this +-- test, one being the case where only one column remains on a line, and +-- the other being the case where a larger portion of the line remains +-- unfilled, but still not sufficient to contain the entire output +-- string. +-- +-- During the course of the test, the file is reset to Append_File mode, +-- and the bounded line length is modified for different lines of the +-- file. +-- +-- APPLICABILITY CRITERIA: +-- This test is applicable to all implementations that support Text_IO +-- processing and external files. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 25 Feb 97 PWB.CTA Allowed for non-support of some IO operations +--! + +with Ada.Text_IO; +with Report; + +procedure CXAA006 is + + A_Bounded_File : Ada.Text_IO.File_Type; + Bounded_File_Name : constant String := + Report.Legal_File_Name ( Nam => "CXAA006" ); + Incomplete : exception; + +begin + + Report.Test ("CXAA006", "Check that procedure Put will correctly " & + "output string items to a bounded line " & + "length text file of mode Append_File"); + + Test_for_Text_IO_Support: + begin + +-- An application creates a text file in mode Append_File, with the intention +-- of using the procedure Put to compress variable length string data into the +-- file in the most efficient manner possible. + + Ada.Text_IO.Create (File => A_Bounded_File, + Mode => Ada.Text_IO.Append_File, + Name => Bounded_File_Name); + exception + when Ada.Text_IO.Use_Error | Ada.Text_IO.Name_Error => + Report.Not_Applicable + ( "Files not supported - Create with Append_File for Text_IO" ); + raise Incomplete; + end Test_For_Text_IO_Support; + + Operational_Test_Block: + declare + Twelve_Characters : constant String := "12Characters"; + Nineteen_Characters : constant String := "Nineteen_Characters"; + TC_Line : Natural := 0; + + function TC_Mode_Selection (Selector : Integer) + return Ada.Text_IO.File_Mode is + begin + case Selector is + when 1 => return Ada.Text_IO.In_File; + when 2 => return Ada.Text_IO.Out_File; + when others => return Ada.Text_IO.Append_File; + end case; + end TC_Mode_Selection; + + begin + +-- The application sets the line length of the file to be bound at 20. All +-- lines in this file will be limited to that length. + + Ada.Text_IO.Set_Line_Length (A_Bounded_File, 20); + + Ada.Text_IO.Put (A_Bounded_File, Nineteen_Characters); + + -- Test control code. + if (Integer(Ada.Text_IO.Line (A_Bounded_File)) /= + Report.Ident_Int(1)) or + (Integer(Ada.Text_IO.Col (A_Bounded_File)) /= + Report.Ident_Int(20)) then + Report.Failed ("Incorrect position after 1st Put"); + end if; + +-- The application finds that there is only one column available on the +-- current line, so the next string item to be output must be broken at +-- the appropriate place (following the first character). + + Ada.Text_IO.Put (File => A_Bounded_File, + Item => Twelve_Characters); + + -- Test control code. + if (Integer(Ada.Text_IO.Line (A_Bounded_File)) /= + Report.Ident_Int(2)) or + (Integer(Ada.Text_IO.Col (A_Bounded_File)) /= + Report.Ident_Int(12)) then + Report.Failed ("Incorrect position after 2nd Put"); + end if; + +-- The application subsequently modifies the processing, resetting the file +-- at this point to In_File mode in order to verify data that has been written +-- to the file. Following this, the application resets the file to Append_File +-- mode in order to continue the placement of data into the file, but modifies +-- the original bounded line length for subsequent lines to be appended. + + -- Reset to Append mode; call outputs page terminator and + -- resets line length to Unbounded. + Reset1: + begin + Ada.Text_IO.Reset (A_Bounded_File, + TC_Mode_Selection (Report.Ident_Int(3))); + exception + when Ada.Text_IO.Use_Error => + Report.Not_Applicable + ( "Reset to Append_File not supported for Text_IO" ); + raise Incomplete; + end Reset1; + + Ada.Text_IO.Set_Line_Length (A_Bounded_File, 15); + + -- Store line number for later comparison. + TC_Line := Natural(Ada.Text_IO.Line(A_Bounded_File)); + +-- The application finds that fifteen columns are available on the current +-- line but that the string item to be output exceeds this available space. +-- It must be split at the end of the line, and the balance placed on the +-- next file line. + + Ada.Text_IO.Put (File => A_Bounded_File, + Item => Nineteen_Characters); + + -- Test control code. + -- Positioned on new line at col 5. + if (Natural(Ada.Text_IO.Line (A_Bounded_File)) /= + (TC_Line + 1)) or + (Integer(Ada.Text_IO.Col (A_Bounded_File)) /= + Report.Ident_Int(5)) then + Report.Failed ("Incorrect position after 3rd Put"); + end if; + + + Test_Verification_Block: + declare + First_String : String (1 .. 80); + Second_String : String (1 .. 80); + Third_String : String (1 .. 80); + Fourth_String : String (1 .. 80); + TC_Width1 : Natural; + TC_Width2 : Natural; + TC_Width3 : Natural; + TC_Width4 : Natural; + begin + +-- The application has the capability to reset the file to In_File mode to +-- verify some or all of the data that is contained there. + + Reset2: + begin + Ada.Text_IO.Reset (A_Bounded_File, Ada.Text_IO.In_File); + exception + when others => + Report.Not_Applicable + ( "Reset to In_File not supported for Text_IO" ); + raise Incomplete; + end Reset2; + + Ada.Text_IO.Get_Line + (A_Bounded_File, First_String, TC_Width1); + Ada.Text_IO.Get_Line + (A_Bounded_File, Second_String, TC_Width2); + Ada.Text_IO.Get_Line + (A_Bounded_File, Third_String, TC_Width3); + Ada.Text_IO.Get_Line + (A_Bounded_File, Fourth_String, TC_Width4); + + -- Test control code. + if (First_String (1..TC_Width1) /= Nineteen_Characters & "1") or + (Second_String (1..TC_Width2) /= "2Characters") or + (Third_String (1..TC_Width3) /= + Nineteen_Characters(1..15)) or + (Fourth_String (1..TC_Width4) /= "ters") + then + Report.Failed ("Data placed incorrectly in file"); + end if; + + exception + + when Incomplete => + raise; + + when Ada.Text_IO.End_Error => + Report.Failed ("Incorrect number of lines in file"); + + when others => + Report.Failed ("Error raised during data verification"); + + end Test_Verification_Block; + + exception + + when Ada.Text_IO.Layout_Error => + Report.Failed ("Layout Error raised when positioning text"); + + when others => + Report.Failed ("Exception in Text_IO processing"); + + end Operational_Test_Block; + + Final_Block: + begin + -- Delete the external file. + if Ada.Text_IO.Is_Open(A_Bounded_File) then + Ada.Text_IO.Delete (A_Bounded_File); + else + Ada.Text_IO.Open (A_Bounded_File, + Ada.Text_IO.In_File, + Bounded_File_Name); + Ada.Text_IO.Delete (A_Bounded_File); + end if; + + exception + when others => + Report.Failed + ( "Delete not properly implemented for Text_IO" ); + end Final_Block; + + Report.Result; + +exception + + when Incomplete => + Report.Result; + when others => + Report.Failed ( "Unexpected exception" ); + Report.Result; + +end CXAA006; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa007.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa007.a new file mode 100644 index 000000000..fe79c2d7a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxaa007.a @@ -0,0 +1,263 @@ +-- CXAA007.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 capabilities of Text_IO.Integer_IO perform correctly +-- on files of Append_File mode, for instantiations with integer and +-- user-defined subtypes. +-- Check that the formatting parameters available in the package can +-- be used and modified successfully in the storage and retrieval of +-- data. +-- +-- TEST DESCRIPTION: +-- This test simulates a receiving department inventory system. Data on +-- items received is entered into an inventory database. This information +-- consists of integer entry number, item number, and bar code. +-- One item is placed into the inventory file immediately following file +-- creation, subsequent items are entered following file opening in +-- Append_File mode. Data items are validated by reading all data from +-- the file and comparing against known values (those used to enter the +-- data originally). +-- +-- This test verifies issues of create in Append_File mode, appending to +-- a file previously appended to, opening in Append_File mode, resetting +-- from Append_File mode to In_File mode, as well as a variety of Text_IO +-- and Integer_IO predefined subprograms. +-- +-- APPLICABILITY CRITERIA: +-- This test is applicable only to implementations that support text +-- files. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 25 Feb 97 PWB.CTA Allowed for non-support of some IO operations +--! + +with Ada.Text_IO; +with Report; + +procedure CXAA007 is + use Ada; + + Inventory_File : Text_IO.File_Type; + Inventory_Filename : constant String := + Report.Legal_File_Name ( Nam => "CXAA007" ); + Incomplete : exception; + +begin + + Report.Test ("CXAA007", "Check that the capabilities of " & + "Text_IO.Integer_IO operate correctly for files " & + "with mode Append_File"); + + Test_for_Text_IO_Support: + begin + + -- An implementation that does not support Text_IO in a particular + -- environment will raise Use_Error on calls to various + -- Text_IO operations. This block statement encloses a call to + -- Create, which should raise the exception in a non-supportive + -- environment. This exception will be handled to produce a + -- Not_Applicable result. + + Text_IO.Create (File => Inventory_File, + Mode => Text_IO.Append_File, + Name => Inventory_Filename); + exception + when Text_IO.Use_Error | Text_IO.Name_Error => + Report.Not_Applicable + ( "Files not supported - Create with Append_File for Text_IO" ); + raise Incomplete; + end Test_for_Text_IO_Support; + + Operational_Test_Block: + declare + + Max_Entries_Per_Order : constant Natural := 4; + + type Bar_Code_Type is range 0 .. 127; -- Values to be stored as base + -- two numbers in file. + type Item_Type is record + Entry_Number : Natural := 0; + Item_Number : Integer := 0; + Bar_Code : Bar_Code_Type := 0; + end record; + + type Inventory_Type is + array (1 .. Max_Entries_Per_Order) of Item_Type; + + Inventory_List : Inventory_Type := ((1, 119, 87), -- Items received + (2, 206, 44), -- this order. + (3, -25, 126), + (4, -18, 31)); + + Daily_Order : constant := 1; + Entry_Field_Width : constant Natural := 1; + Item_Base : constant Natural := 16; + Items_Inventoried : Natural := 1; + Items_To_Inventory : Natural := 4; + + package Entry_IO is new Text_IO.Integer_IO (Natural); + package Item_IO is new Text_IO.Integer_IO (Integer); + package Bar_Code_IO is new Text_IO.Integer_IO (Bar_Code_Type); + + + -- The following procedure simulates the addition of inventory item + -- information into a data file. + + procedure Update_Inventory (The_Item : in Item_Type) is + Spacer : constant String := " "; + begin + -- Enter all the incoming data into the inventory file. + Entry_IO.Put (Inventory_File, The_Item.Entry_Number); + Text_IO.Put (Inventory_File, Spacer); + Item_IO.Put (Inventory_File, The_Item.Item_Number); + Text_IO.Put (Inventory_File, Spacer); + Bar_Code_IO.Put(File => Inventory_File, + Item => The_Item.Bar_Code, + Width => 13, + Base => 2); + Text_IO.New_Line(Inventory_File); + end Update_Inventory; + + + begin + + -- This code section simulates a receiving department maintaining a + -- data file containing information on items that have been ordered + -- and received. + -- + -- As new orders are received, the file is opened in Append_File + -- mode. + -- Data is taken from the inventory list and entered into the file, + -- in specific format. + -- Enter the order into the inventory file. This is item 1 in + -- the inventory list. + -- The data entry process can be repeated numerous times as required. + + Entry_IO.Put (Inventory_File, + Inventory_List(Daily_Order).Entry_Number); + Item_IO.Put (Inventory_File, + Inventory_List(Daily_Order).Item_Number); + Bar_Code_IO.Put (File => Inventory_File, + Item => Inventory_List(Daily_Order).Bar_Code); + Text_IO.New_Line (Inventory_File); + + Text_IO.Close (Inventory_File); + + + Entry_IO.Default_Width := Entry_Field_Width; -- Modify the default + -- width of Entry_IO. + Item_IO.Default_Base := Item_Base; -- Modify the default + -- number base of + -- Item_IO + Text_IO.Open (Inventory_File, + Text_IO.Append_File, -- Open in Append mode. + Inventory_Filename); + -- Enter items + while (Items_Inventoried < Items_To_Inventory) loop -- 2-4 into the + Items_Inventoried := Items_Inventoried + 1; -- inventory file. + Update_Inventory (The_Item => Inventory_List (Items_Inventoried)); + end loop; + + Test_Verification_Block: -- Read and check + declare -- all the data + TC_Entry : Natural; -- values that + TC_Item : Integer; -- have been + TC_Bar_Code : Bar_Code_Type; -- entered in the + TC_Item_Count : Natural := 0; -- data file. + begin + + Reset1: + begin + Text_IO.Reset (Inventory_File, Text_IO.In_File); -- Reset for + -- reading. + exception + when Text_IO.Use_Error => + Report.Not_Applicable + ( "Reset to mode In_File not supported for Text_IO" ); + raise Incomplete; + end Reset1; + + while not Text_IO.End_Of_File (Inventory_File) loop + Entry_IO.Get (Inventory_File, TC_Entry); + Item_IO.Get (Inventory_File, TC_Item); + Bar_Code_IO.Get (Inventory_File, TC_Bar_Code); + Text_IO.Skip_Line (Inventory_File); + TC_Item_Count := TC_Item_Count + 1; + + if (TC_Item /= Inventory_List(TC_Entry).Item_Number) or + (TC_Bar_Code /= Inventory_List(TC_Entry).Bar_Code) then + Report.Failed ("Error in integer data read from file"); + end if; + end loop; + + if (TC_Item_Count /= Max_Entries_Per_Order) then + Report.Failed ("Incorrect number of records read from file"); + end if; + + exception + when Incomplete => + raise; + when others => + Report.Failed ("Error raised during data verification"); + end Test_Verification_Block; + + exception + when Incomplete => + raise; + when others => + Report.Failed ("Exception in Text_IO.Integer_IO processing"); + end Operational_Test_Block; + + Final_Block: + begin + -- Delete the external file. + if Text_IO.Is_Open(Inventory_File) then + Text_IO.Delete (Inventory_File); + else + Text_IO.Open (Inventory_File, Text_IO.In_File, Inventory_Filename); + Text_IO.Delete (Inventory_File); + end if; + + exception + + when others => + Report.Failed ( "Delete not properly implemented for Text_IO" ); + + end Final_Block; + + Report.Result; + +exception + + when Incomplete => + Report.Result; + when others => + Report.Failed ( "Unexpected exception" ); + Report.Result; + +end CXAA007; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa008.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa008.a new file mode 100644 index 000000000..c21d07ea9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxaa008.a @@ -0,0 +1,271 @@ +-- CXAA008.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 capabilities provided in instantiations of the +-- Ada.Text_IO.Fixed_IO package operate correctly when the mode of +-- the file is Append_File. Check that Fixed_IO procedures Put and Get +-- properly transfer fixed point data to/from data files that are in +-- Append_File mode. Check that the formatting parameters available in +-- the package can be used and modified successfully in the appending and +-- retrieval of data. +-- +-- TEST DESCRIPTION: +-- This test simulates order processing, with data values being written +-- to a file, in a specific format, using Fixed_IO. Validation is done +-- on this process by reading the data values from the file, and +-- comparing them for equality with the values originally written to +-- the file. +-- +-- This test verifies issues of create in Append_File mode, appending to +-- a file previously appended to, resetting to Append_File mode, +-- resetting from Append_File mode to In_File mode, as well as a +-- variety of Text_IO and Fixed_IO predefined subprograms. +-- +-- APPLICABILITY CRITERIA: +-- This test is applicable only to implementations that support text +-- files. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 25 Feb 97 PWB.CTA Allowed for non-support of some IO operations +--! + +with Ada.Text_IO; +with Report; + +procedure CXAA008 is + use Ada; + + Inventory_File : Text_IO.File_Type; + Inventory_Filename : constant String := + Report.Legal_File_Name ( Nam => "CXAA008" ); + Incomplete : exception; + +begin + + Report.Test ("CXAA008", "Check that the capabilities of " & + "Text_IO.Fixed_IO operate correctly for files " & + "with mode Append_File"); + + Test_for_Text_IO_Support: + begin + + -- An implementation that does not support Text_IO in a particular + -- environment will raise Use_Error on calls to various + -- Text_IO operations. This block statement encloses a call to + -- Create, which should raise the exception in a non-supportive + -- environment. This exception will be handled to produce a + -- Not_Applicable result. + + Text_IO.Create (File => Inventory_File, + Mode => Text_IO.Append_File, + Name => Inventory_Filename); + + exception + when Text_IO.Use_Error | Text_IO.Name_Error => + Report.Not_Applicable + ( "Files not supported - Create with Append_File for Text_IO" ); + raise Incomplete; + end Test_For_Text_IO_Support; + + Operational_Test_Block: + declare + + Daily_Orders_Received : constant Natural := 4; + + type Item_Type is delta 0.1 range 0.0 .. 5000.0; + type Cost_Type is delta 0.01 range 0.0 .. 10_000.0; + type Profit_Type is delta 0.01 range -100.0 .. 1000.0; + + type Product_Type is record + Item_Number : Item_Type := 0.0; + Unit_Cost : Cost_Type := 0.00; + Percent_Markup : Profit_Type := 0.00; + end record; + + type Inventory_Type is + array (1 .. Daily_Orders_Received) of Product_Type; + + Daily_Inventory : Inventory_Type := (( 1.0, 1.75, 50.00), + ( 155.0, 20.00, -5.50), + (3343.5, 2.50, 126.50), + (4986.0, 180.00, 31.75)); + + package Item_IO is new Text_IO.Fixed_IO (Item_Type); + package Cost_IO is new Text_IO.Fixed_IO (Cost_Type); + package Markup_IO is new Text_IO.Fixed_IO (Profit_Type); + + + function TC_Mode_Selection (Selector : Integer) + return Text_IO.File_Mode is + begin + case Selector is + when 1 => return Text_IO.In_File; + when 2 => return Text_IO.Out_File; + when others => return Text_IO.Append_File; + end case; + end TC_Mode_Selection; + + + -- The following function simulates the addition of inventory item + -- information into a data file. Boolean status of True is returned + -- if all of the data entry was successful, False otherwise. + + function Update_Inventory (The_List : Inventory_Type) + return Boolean is + begin + for I in 1 .. Daily_Orders_Received loop + Item_IO.Put (Inventory_File, The_List(I).Item_Number); + Cost_IO.Put (Inventory_File, The_List(I).Unit_Cost, 10, 4, 0); + Markup_IO.Put(File => Inventory_File, + Item => The_List(I).Percent_Markup, + Fore => 6, + Aft => 3, + Exp => 2); + Text_IO.New_Line (Inventory_File); + end loop; + return (True); -- Return a Status value. + exception + when others => return False; + end Update_Inventory; + + + begin + + -- This code section simulates a receiving department maintaining a + -- data file containing information on items that have been ordered + -- and received. + + -- Whenever items are received, the file is reset to Append_File + -- mode. Data is taken from an inventory list and entered into the + -- file, in specific format. + + Reset1: + begin -- Reset to + Text_IO.Reset (Inventory_File, -- Append mode. + TC_Mode_Selection (Report.Ident_Int(3))); + exception + when Text_IO.Use_Error => + Report.Not_Applicable + ( "Reset to Append_File not supported for Text_IO" ); + end Reset1; + + -- Enter data. + if not Update_Inventory (The_List => Daily_Inventory) then + Report.Failed ("Exception occurred during inventory update"); + raise Incomplete; + end if; + + Test_Verification_Block: + declare + TC_Item : Item_Type; + TC_Cost : Cost_Type; + TC_Markup : Profit_Type; + TC_Item_Count : Natural := 0; + begin + + Reset2: + begin + Text_IO.Reset (Inventory_File, Text_IO.In_File); -- Reset for + -- reading. + exception + when Text_IO.Use_Error => + Report.Not_Applicable + ( "Reset to In_File not supported for Text_IO" ); + raise Incomplete; + end Reset2; + + while not Text_IO.End_Of_File (Inventory_File) loop + Item_IO.Get (Inventory_File, TC_Item); + Cost_IO.Get (Inventory_File, TC_Cost); + Markup_IO.Get (File => Inventory_File, + Item => TC_Markup, + Width => 0); + Text_IO.Skip_Line (Inventory_File); + TC_Item_Count := TC_Item_Count + 1; + + -- Verify all of the data fields read from the file. Compare + -- with the values that were originally entered into the file. + + if (TC_Item /= Daily_Inventory(TC_Item_Count).Item_Number) then + Report.Failed ("Error in Item_Number read from file"); + end if; + if (TC_Cost /= Daily_Inventory(TC_Item_Count).Unit_Cost) then + Report.Failed ("Error in Unit_Cost read from file"); + end if; + if not (TC_Markup = + Daily_Inventory(TC_Item_Count).Percent_Markup) then + Report.Failed ("Error in Percent_Markup read from file"); + end if; + + end loop; + + if (TC_Item_Count /= Daily_Orders_Received) then + Report.Failed ("Incorrect number of records read from file"); + end if; + + exception + when Incomplete => + raise; + when others => + Report.Failed ("Error raised during data verification"); + end Test_Verification_Block; + + exception + when Incomplete => + raise; + when others => + Report.Failed ("Exception in Text_IO.Fixed_IO processing"); + end Operational_Test_Block; + + Final_Block: + begin + -- Delete the external file. + if Text_IO.Is_Open (Inventory_File) then + Text_IO.Delete (Inventory_File); + else + Text_IO.Open (Inventory_File, Text_IO.In_File, Inventory_Filename); + Text_IO.Delete (Inventory_File); + end if; + + exception + + when others => + Report.Failed ( "Delete not properly implemented for Text_IO" ); + + end Final_Block; + + Report.Result; + +exception + when Incomplete => + Report.Result; + when others => + Report.Failed ( "Unexpected exception" ); + Report.Result; + +end CXAA008; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa009.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa009.a new file mode 100644 index 000000000..d47806080 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxaa009.a @@ -0,0 +1,290 @@ +-- CXAA009.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 capabilities provided in instantiations of the +-- Ada.Text_IO.Float_IO package operate correctly when the mode of +-- the file is Append_File. Check that Float_IO procedures Put and Get +-- properly transfer floating point data to/from data files that are in +-- Append_File mode. Check that the formatting parameters available in +-- the package can be used and modified successfully in the appending and +-- retrieval of data. +-- +-- TEST DESCRIPTION: +-- This test is designed to simulate an environment where a data file +-- that holds floating point information is created, written to, and +-- closed. In the future, the file can be reopened in Append_File mode, +-- additional data can be appended to it, and then closed. This process +-- of Open/Append/Close can be repeated as necessary. All data written +-- to the file is verified for accuracy when retrieved from the file. +-- +-- This test verifies issues of create in Append_File mode, appending to +-- a file previously appended to, opening in Append_File mode, resetting +-- from Append_File mode to In_File mode, as well as a variety of Text_IO +-- and Float_IO predefined subprograms. +-- +-- APPLICABILITY CRITERIA: +-- This test is applicable only to implementations that support text +-- files. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 25 Feb 97 PWB.CTA Allowed for non-support of some IO operations +--! + +with Ada.Text_IO; +with Report; + +procedure CXAA009 is + + use Ada; + Loan_File : Text_IO.File_Type; + Loan_Filename : constant String := + Report.Legal_File_Name ( Nam => "CXAA009" ); + Incomplete : exception; + +begin + + Report.Test ("CXAA009", "Check that the capabilities of " & + "Text_IO.Float_IO operate correctly for files " & + "with mode Append_File"); + + Test_for_Text_IO_Support: + begin + + -- An implementation that does not support Text_IO in a particular + -- environment will raise Use_Error on calls to various + -- Text_IO operations. This block statement encloses a call to + -- Create, which should raise the exception in a non-supportive + -- environment. This exception will be handled to produce a + -- Not_Applicable result. + + Text_IO.Create (File => Loan_File, -- Create in + Mode => Text_IO.Out_File, -- Out_File mode. + Name => Loan_Filename); + + exception + + when Text_IO.Use_Error | Text_IO.Name_Error => + Report.Not_Applicable + ( "Files not supported - Create as Out_File for Text_IO" ); + raise Incomplete; + + end Test_for_Text_IO_Support; + + Operational_Test_Block: + declare + Total_Loans_Outstanding : constant Natural := 3; + Transaction_Status : Boolean := False; + + type Account_Balance_Type is digits 6 range 0.0 .. 1.0E6; + type Loan_Balance_Type is digits 6; + type Interest_Rate_Type is digits 4 range 0.0 .. 30.00; + + type Loan_Info_Type is record + Account_Balance : Account_Balance_Type := 0.00; + Loan_Balance : Loan_Balance_Type := 0.00; + Loan_Interest_Rate : Interest_Rate_Type := 0.00; + end record; + + Home_Refinance_Loan : Loan_Info_Type := + (14_500.00, 135_000.00, 6.875); + Line_Of_Credit_Loan : Loan_Info_Type := + ( 5490.00, -3000.00, 13.75); + Small_Business_Loan : Loan_Info_Type := + (Account_Balance => 45_000.00, + Loan_Balance => 10_500.00, + Loan_Interest_Rate => 5.875); + + package Acct_IO is new Text_IO.Float_IO (Account_Balance_Type); + package Loan_IO is new Text_IO.Float_IO (Loan_Balance_Type); + package Rate_IO is new Text_IO.Float_IO (Interest_Rate_Type); + + + -- The following procedure performs the addition of loan information + -- into a data file. Boolean status of True is returned if all of + -- the data entry was successful, False otherwise. + -- This demonstrates use of Float_IO using a variety of data formats. + + procedure Update_Loan_Info (The_File : in out Text_IO.File_Type; + The_Loan : in Loan_Info_Type; + Status : out Boolean ) is + begin + Acct_IO.Put (The_File, The_Loan.Account_Balance); + Loan_IO.Put (The_File, The_Loan.Loan_Balance, 15, 2, 0); + Rate_IO.Put (File => The_File, + Item => The_Loan.Loan_Interest_Rate, + Fore => 6, + Aft => 3, + Exp => 0); + Text_IO.New_Line (The_File); + Status := True; + exception + when others => Status := False; + end Update_Loan_Info; + + + begin + + -- This code section simulates a bank maintaining a data file + -- containing information on loans that have been made. + -- The scenario: + -- The loan file was created in Out_File mode. + -- Some number of data records are added. + -- The file is closed. + -- The file is subsequently reopened in Append_File mode. + -- Data is appended to the file. + -- The file is closed. + -- Repeat the Open/Append/Close process as required. + -- Verify data in the file. + -- etc. + + Update_Loan_Info(Loan_File, Home_Refinance_Loan, Transaction_Status); + + if not Transaction_Status then + Report.Failed ("Failure in update of first loan data"); + end if; + + Text_IO.Close (Loan_File); + + -- When subsequent data items are to be added to the file, the file + -- is opened in Append_File mode. + + Text_IO.Open (Loan_File, -- Open with + Text_IO.Append_File, -- Append mode. + Loan_Filename); + + Update_Loan_Info(Loan_File, Line_Of_Credit_Loan, Transaction_Status); + + if not Transaction_Status then + Report.Failed("Failure in update of first loan data"); + end if; + + Text_IO.Close(Loan_File); + + -- To add additional data to the file, the file + -- is again opened in Append_File mode (appending to a file + -- previously appended to). + + Text_IO.Open (Loan_File, -- Open with + Text_IO.Append_File, -- Append mode. + Loan_Filename); + + Update_Loan_Info(Loan_File, Small_Business_Loan, Transaction_Status); + + if not Transaction_Status then + Report.Failed("Failure in update of first loan data"); + end if; + + Test_Verification_Block: + declare + type Ledger_Type is + array (1 .. Total_Loans_Outstanding) of Loan_Info_Type; + TC_Bank_Ledger : Ledger_Type; + TC_Item_Count : Natural := 0; + begin + + Reset1: + begin + Text_IO.Reset (Loan_File, Text_IO.In_File); -- Reset for + -- reading. + exception + when Text_IO.Use_Error => + Report.Not_Applicable + ( "Reset to In_File not supported for Text_IO" ); + raise Incomplete; + end Reset1; + + while not Text_IO.End_Of_File (Loan_File) loop + TC_Item_Count := TC_Item_Count + 1; + Acct_IO.Get (Loan_File, + TC_Bank_Ledger(TC_Item_Count).Account_Balance); + Loan_IO.Get (Loan_File, + TC_Bank_Ledger(TC_Item_Count).Loan_Balance, + 0); + Rate_IO.Get(File => Loan_File, + Item => + TC_Bank_Ledger(TC_Item_Count).Loan_Interest_Rate, + Width => 0); + Text_IO.Skip_Line(Loan_File); + + end loop; + + -- Verify all of the data fields read from the file. Compare + -- with the values that were originally entered into the file. + + if (TC_Bank_Ledger(1) /= Home_Refinance_Loan) or + (TC_Bank_Ledger(2) /= Line_Of_Credit_Loan) or + (TC_Bank_Ledger(3) /= Small_Business_Loan) then + Report.Failed("Error in data read from file"); + end if; + + if (TC_Item_Count /= Total_Loans_Outstanding) then + Report.Failed ("Incorrect number of records read from file"); + end if; + + exception + when Incomplete => + raise; + when others => + Report.Failed ("Error raised during data verification"); + end Test_Verification_Block; + + exception + when Incomplete => + raise; + when others => + Report.Failed ("Exception in Text_IO.Float_IO processing"); + end Operational_Test_Block; + + Final_Block: + begin + -- Delete the external file. + if Text_IO.Is_Open(Loan_File) then + Text_IO.Delete(Loan_File); + else + Text_IO.Open(Loan_File, Text_IO.In_File, Loan_Filename); + Text_IO.Delete(Loan_File); + end if; + + exception + + when Text_IO.Use_Error => + Report.Failed + ( "Delete not properly implemented for Text_IO" ); + + end Final_Block; + + Report.Result; + +exception + when Incomplete => + Report.Result; + when others => + Report.Failed ( "Unexpected exception" ); + Report.Result; + +end CXAA009; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa010.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa010.a new file mode 100644 index 000000000..5678aee6b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxaa010.a @@ -0,0 +1,335 @@ +-- CXAA010.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 operations defined in package Ada.Text_IO.Decimal_IO +-- are available, and that they function correctly when used for the +-- input/output of Decimal types. +-- +-- TEST DESCRIPTION: +-- This test demonstrates the Put and Get procedures found in the +-- generic package Ada.Text_IO.Decimal_IO. Both Put and Get are +-- overloaded to allow placement or extraction of decimal values +-- to/from a text file or a string. This test demonstrates both forms +-- of each subprogram. +-- The test defines an array of records containing decimal value +-- and string component fields. All component values are placed in a +-- Text_IO file, with the decimal values being placed there using the +-- version of Put defined for files, and using user-specified formatting +-- parameters. The data is later extracted from the file, with the +-- decimal values being removed using the version of Get defined for +-- files. Decimal values are then written to strings, using the +-- appropriate Put procedure. Finally, extraction of the decimal data +-- from the strings completes the evaluation of the Decimal_IO package +-- subprograms. +-- The reconstructed data is verified at the end of the test against the +-- data originally written to the file. +-- +-- APPLICABILITY CRITERIA: +-- Applicable to all implementations capable of supporting external +-- Text_IO files and Decimal Fixed Point Types +-- +-- All implementations must attempt to compile this test. +-- +-- For implementations validating against Information Systems Annex (F): +-- this test must execute and report PASSED. +-- +-- For implementations not validating against Annex F: +-- this test may report compile time errors at one or more points +-- indicated by "-- ANX-F RQMT", in which case it may be graded as inapplicable. +-- Otherwise, the test must execute and report PASSED. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 20 Feb 95 SAIC Modified test to allow for Use_Error/Name_Error +-- generation by an implementation not supporting +-- Text_IO operations. +-- 14 Nov 95 SAIC Corrected string indexing for ACVC 2.0.1. +-- 27 Feb 97 PWB.CTA Allowed for non-support of some IO operations +-- 16 FEB 98 EDS Modified documentation. +--! + +with Ada.Text_IO; +with Report; + +procedure CXAA010 is + use Ada.Text_IO; + Tax_Roll : Ada.Text_IO.File_Type; + Tax_Roll_Name : constant String := + Report.Legal_File_Name ( Nam => "CXAA010" ); + Incomplete : exception; +begin + + Report.Test ("CXAA010", "Check that the operations defined in package " & + "Ada.Text_IO.Decimal_IO are available, and " & + "that they function correctly when used for " & + "the input/output of Decimal types"); + + Test_for_Decimal_IO_Support: + begin + + -- An implementation that does not support Text_IO creation or naming + -- of external files in a particular environment will raise Use_Error + -- or Name_Error on a call to Text_IO Create. This block statement + -- encloses a call to Create, which should produce an exception in a + -- non-supportive environment. Either of these exceptions will be + -- handled to produce a Not_Applicable result. + + Ada.Text_IO.Create (Tax_Roll, Ada.Text_IO.Out_File, Tax_Roll_Name); + + exception + + when Ada.Text_IO.Use_Error | Ada.Text_IO.Name_Error => + Report.Not_Applicable + ( "Files not supported - Create as Out_File for Text_IO" ); + raise Incomplete; + + end Test_for_Decimal_IO_Support; + + Taxation: + declare + + ID_Length : constant := 5; + Price_String_Length : constant := 5; + Value_String_Length : constant := 6; + Total_String_Length : constant := 20; + Spacer : constant String := " "; -- Two blanks. + + type Price_Type is delta 0.1 digits 4; -- ANX-F RQMT + type Value_Type is delta 0.01 digits 5; -- ANX-F RQMT + + type Property_Type is + record + Parcel_ID : String (1..ID_Length); + Purchase_Price : Price_Type; + Assessed_Value : Value_Type; + end record; + + type City_Block_Type is array (1..4) of Property_Type; + + subtype Tax_Bill_Type is string (1..Total_String_Length); + type Tax_Bill_Array_Type is array (1..4) of Tax_Bill_Type; + + Neighborhood : City_Block_Type := + (("X9254", 123.0, 135.00), ("X3569", 345.0, 140.50), + ("X3434", 234.0, 179.50), ("X8838", 456.0, 158.00)); + + Neighborhood_Taxes : Tax_Bill_Array_Type; + + package Price_IO is new Ada.Text_IO.Decimal_IO (Price_Type); + package Value_IO is new Ada.Text_IO.Decimal_IO (Value_Type); + + begin -- Taxation + + Assessors_Office: + begin + + for Parcel in City_Block_Type'Range loop + -- Note: All data in the file will be separated with a + -- two-character blank spacer. + Ada.Text_IO.Put(Tax_Roll, Neighborhood(Parcel).Parcel_ID); + Ada.Text_IO.Put(Tax_Roll, Spacer); + + -- Use Decimal_IO.Put with non-default format parameters to + -- place decimal data into file. + Price_IO.Put (Tax_Roll, Neighborhood(Parcel).Purchase_Price, + Fore => 3, Aft =>1, Exp => 0); + Ada.Text_IO.Put(Tax_Roll, Spacer); + + Value_IO.Put (Tax_Roll, Neighborhood(Parcel).Assessed_Value, + Fore => 3, Aft =>2, Exp => 0); + Ada.Text_IO.New_Line(Tax_Roll); + end loop; + + Ada.Text_IO.Close (Tax_Roll); + + exception + when others => + Report.Failed ("Exception raised in Assessor's Office"); + end Assessors_Office; + + + Twice_A_Year: + declare + + procedure Collect_Tax(Index : in Integer; + Tax_Array : in out Tax_Bill_Array_Type) is + ID : String (1..ID_Length); + Price : Price_Type := 0.0; + Value : Value_Type := 0.00; + Price_String : String (1..Price_String_Length); + Value_String : String (1..Value_String_Length); + begin + + -- Extract information from the Text_IO file; one string, two + -- decimal values. + -- Note that the Spacers that were put in the file above are + -- not individually read here, due to the fact that each call + -- to Decimal_IO.Get below uses a zero in the Width field, + -- which allows each Get procedure to skip these leading blanks + -- prior to extracting the numeric value. + + Ada.Text_IO.Get (Tax_Roll, ID); + + -- A zero value of Width is provided, so the following + -- two calls to Decimal_IO.Get will skip the leading blanks, + -- (from the Spacer variable above), then read the numeric + -- literals. + + Price_IO.Get (Tax_Roll, Price, 0); + Value_IO.Get (Tax_Roll, Value, 0); + Ada.Text_IO.Skip_Line (Tax_Roll); + + -- Convert the values read from the file into string format, + -- using user-specified format parameters. + -- Format of the Price_String should be "nnn.n" + -- Format of the Value_String should be "nnn.nn" + + Price_IO.Put (To => Price_String, + Item => Price, + Aft => 1); + Value_IO.Put (Value_String, Value, 2); + + -- Construct a string of length 20 that contains the Parcel_ID, + -- the Purchase_Price, and the Assessed_Value, separated by + -- two-character blank data spacers. Store this string + -- into the string array out parameter. + -- Format of each Tax_Array element should be + -- "Xnnnn nnn.n nnn.nn" (with an 'n' signifying a digit). + + Tax_Array(Index) := ID & Spacer & + Price_String & Spacer & + Value_String; + exception + when Data_Error => + Report.Failed("Data Error raised during the extraction " & + "of decimal data from the file"); + when others => + Report.Failed("Exception in Collect_Tax procedure"); + end Collect_Tax; + + + begin -- Twice_A_Year + + Ada.Text_IO.Open (Tax_Roll, Ada.Text_IO.In_File, Tax_Roll_Name); + + -- Determine property tax bills for the entire neighborhood from + -- the information that is stored in the file. Store information + -- in the Neighborhood_Taxes string array. + + for Parcel in City_Block_Type'Range loop + Collect_Tax (Parcel, Neighborhood_Taxes); + end loop; + + exception + when others => + Report.Failed ("Exception in Twice_A_Year Block"); + end Twice_A_Year; + + -- Use Decimal_IO Get procedure to extract information from a string. + -- Verify data against original values. + Validation_Block: + declare + TC_ID : String (1..ID_Length); -- 1..5 + TC_Price : Price_Type; + TC_Value : Value_Type; + Length : Positive; + Front, + Rear : Integer := 0; + begin + + for Parcel in City_Block_Type'Range loop + -- Extract values from the strings of the string array. + -- Each element of the string array is 20 characters long; the + -- first five characters are the Parcel_ID, two blank characters + -- separate data, the next five characters contain the Price + -- decimal value, two blank characters separate data, the last + -- six characters contain the Value decimal value. + -- Extract each of these components in turn. + + Front := 1; -- 1 + Rear := ID_Length; -- 5 + TC_ID := Neighborhood_Taxes(Parcel)(Front..Rear); + + -- Extract the decimal value from the next slice of the string. + Front := Rear + 3; -- 8 + Rear := Front + Price_String_Length - 1; -- 12 + Price_IO.Get (Neighborhood_Taxes(Parcel)(Front..Rear), + Item => TC_Price, + Last => Length); + + -- Extract next decimal value from slice of string, based on + -- length of preceding strings read from string array element. + Front := Rear + 3; -- 15 + Rear := Total_String_Length; -- 20 + Value_IO.Get (Neighborhood_Taxes(Parcel)(Front..Rear), + Item => TC_Value, + Last => Length); + + if TC_ID /= Neighborhood(Parcel).Parcel_ID or + TC_Price /= Neighborhood(Parcel).Purchase_Price or + TC_Value /= Neighborhood(Parcel).Assessed_Value + then + Report.Failed ("Incorrect data validation"); + end if; + + end loop; + + exception + when others => Report.Failed ("Exception in Validation Block"); + end Validation_Block; + + -- Check that the Text_IO file is open, then delete. + + if not Ada.Text_IO.Is_Open (Tax_Roll) then + Report.Failed ("File not left open after processing"); + Ada.Text_IO.Open (Tax_Roll, Ada.Text_IO.Out_File, Tax_Roll_Name); + end if; + + Ada.Text_IO.Delete (Tax_Roll); + + exception + when others => + Report.Failed ("Exception in Taxation block"); + -- Check that the Text_IO file is open, then delete. + if not Ada.Text_IO.Is_Open (Tax_Roll) then + Ada.Text_IO.Open (Tax_Roll, + Ada.Text_IO.Out_File, + Tax_Roll_Name); + end if; + Ada.Text_IO.Delete (Tax_Roll); + end Taxation; + + Report.Result; + +exception + when Incomplete => + Report.Result; + when others => + Report.Failed ( "Unexpected exception" ); + Report.Result; + +end CXAA010; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa011.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa011.a new file mode 100644 index 000000000..8cc136d35 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxaa011.a @@ -0,0 +1,266 @@ +-- CXAA011.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 operations of Text_IO.Enumeration_IO perform correctly +-- on files of Append_File mode, for instantiations using +-- enumeration types. Check that Enumeration_IO procedures Put and Get +-- properly transfer enumeration data to/from data files. +-- Check that the formatting parameters available in the package can +-- be used and modified successfully in the storage and retrieval of data. +-- +-- TEST DESCRIPTION: +-- This test is designed to simulate an environment where a data file +-- that holds enumeration type information is reset from it current mode +-- to allow the appending of data to the end of the This process +-- of Reset/Write can be repeated as necessary. All data written +-- to the file is verified for accuracy when retrieved from the file. +-- +-- This test verifies issues of resetting a file created in Out_File mode +-- to Append_File mode, resetting from Append_File mode to In_File mode, +-- as well as a variety of Text_IO and Enumeration_IO predefined +-- subprograms. +-- +-- APPLICABILITY CRITERIA: +-- This test is applicable only to implementations that support text +-- files. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 25 Feb 97 PWB.CTA Allowed for non-support of some IO operations +--! + +with Ada.Text_IO; +with Report; + +procedure CXAA011 is + use Ada; + + Status_Log : Text_IO.File_Type; + Status_Log_Filename : constant String := + Report.Legal_File_Name ( Nam => "CXAA011" ); + Incomplete : exception; + +begin + + Report.Test ("CXAA011", "Check that the operations of " & + "Text_IO.Enumeration_IO operate correctly for " & + "files with mode Append_File"); + + Test_for_Text_IO_Support: + begin + + -- An implementation that does not support Text_IO in a particular + -- environment will raise Use_Error on calls to various + -- Text_IO operations. This block statement encloses a call to + -- Create, which should raise the exception in a non-supportive + -- environment. This exception will be handled to produce a + -- Not_Applicable result. + + Text_IO.Create (File => Status_Log, + Mode => Text_IO.Out_File, + Name => Status_Log_Filename); + exception + + when Text_IO.Use_Error | Text_IO.Name_Error => + Report.Not_Applicable + ( "Files not supported - Create as Out_File for Text_IO" ); + raise Incomplete; + + end Test_for_Text_IO_Support; + + + Operational_Test_Block: + declare + + type Days_In_Week is (Monday, Tuesday, Wednesday, Thursday, Friday, + Saturday, Sunday); + type Hours_In_Day is (A0000, A0600, P1200, P0600); -- Six hour + -- blocks. + type Status_Type is (Operational, Off_Line); + + type Status_Record_Type is record + Day : Days_In_Week; + Hour : Hours_In_Day; + Status : Status_Type; + end record; + + Morning_Reading : Status_Record_Type := + (Wednesday, A0600, Operational); + Evening_Reading : Status_Record_Type := + (Saturday, P0600, Off_Line); + + package Day_IO is new Text_IO.Enumeration_IO (Days_In_Week); + package Hours_IO is new Text_IO.Enumeration_IO (Hours_In_Day); + package Status_IO is new Text_IO.Enumeration_IO (Status_Type); + + + -- The following function simulates the hourly recording of equipment + -- status. + + function Record_Status (Reading : Status_Record_Type) + return Boolean is + use Text_IO; -- To provide visibility to type Type_Set and + -- enumeration literal Upper_Case. + begin + Day_IO.Put (File => Status_Log, + Item => Reading.Day, + Set => Type_Set'(Upper_Case)); + Hours_IO.Put (Status_Log, Reading.Hour, 7); + Status_IO.Put (Status_Log, Reading.Status, + Width => 8, Set => Lower_Case); + Text_IO.New_Line (Status_Log); + return (True); + exception + when others => return False; + end Record_Status; + + begin + + -- The usage scenario intended is as follows: + -- File is created. + -- Unrelated/unknown file processing occurs. + -- On six hour intervals, file is reset to Append_File mode. + -- Data is appended to file. + -- Unrelated/unknown file processing resumes. + -- Reset/Append process is repeated. + + Reset1: + begin + Text_IO.Reset (Status_Log, -- Reset to + Text_IO.Append_File); -- Append mode. + exception + when Text_IO.Use_Error => + Report.Not_Applicable + ( "Reset to Append_File not supported for Text_IO" ); + raise Incomplete; + end Reset1; + + Day_IO.Default_Width := Days_In_Week'Width + 5; -- Default values + -- are modifiable. + + if not Record_Status (Morning_Reading) then -- Enter data. + Report.Failed ("Exception occurred during data file update"); + end if; + + Reset2: + begin + Text_IO.Reset (Status_Log, -- Reset to + Text_IO.Append_File); -- Append mode. + exception + when Text_IO.Use_Error => + Report.Not_Applicable + ( "Reset to Append_File not supported for Text_IO" ); + raise Incomplete; + end Reset2; + + if not Record_Status (Evening_Reading) then -- Enter data. + Report.Failed ("Exception occurred during data file update"); + end if; + + Test_Verification_Block: + declare + TC_Reading1 : Status_Record_Type; + TC_Reading2 : Status_Record_Type; + begin + + Reset3: + begin + Text_IO.Reset (Status_Log, Text_IO.In_File); -- Reset for + -- reading. + exception + when Text_IO.Use_Error => + Report.Not_Applicable + ( "Reset to In_File not supported for Text_IO" ); + raise Incomplete; + end Reset3; + + Day_IO.Get (Status_Log, TC_Reading1.Day); -- Read data from + Hours_IO.Get (Status_Log, TC_Reading1.Hour); -- first record. + Status_IO.Get (Status_Log, TC_Reading1.Status); + Text_IO.Skip_Line (Status_Log); + + -- Verify the data read from the file. Compare with the + -- record that was originally entered into the file. + + if (TC_Reading1 /= Morning_Reading) then + Report.Failed ("Data error on reading first record"); + end if; + + Day_IO.Get (Status_Log, TC_Reading2.Day); -- Read data from + Hours_IO.Get (Status_Log, TC_Reading2.Hour); -- second record. + Status_IO.Get (Status_Log, TC_Reading2.Status); + Text_IO.Skip_Line (Status_Log); + + -- Verify all of the data fields read from the file. Compare + -- with the values that were originally entered into the file. + + if (TC_Reading2.Day /= Evening_Reading.Day) or + (TC_Reading2.Hour /= Evening_Reading.Hour) or + (TC_Reading2.Status /= Evening_Reading.Status) then + Report.Failed ("Data error on reading second record"); + end if; + + exception + when Incomplete => + raise; + when others => + Report.Failed ("Error raised during data verification"); + end Test_Verification_Block; + + exception + when Incomplete => + raise; + when others => + Report.Failed ("Exception in Text_IO.Enumeration_IO processing"); + end Operational_Test_Block; + + Final_Block: + begin + -- Delete the external file. + if Text_IO.Is_Open (Status_Log) then + Text_IO.Delete (Status_Log); + else + Text_IO.Open (Status_Log, Text_IO.Out_File, Status_Log_Filename); + Text_IO.Delete (Status_Log); + end if; + exception + when Text_IO.Use_Error => + Report.Failed + ( "Delete not properly implemented for Text_IO" ); + + end Final_Block; + + Report.Result; + +exception + when Incomplete => + Report.Result; + when others => + Report.Failed ( "Unexpected exception" ); + Report.Result; + +end CXAA011; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa012.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa012.a new file mode 100644 index 000000000..07523b441 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxaa012.a @@ -0,0 +1,167 @@ +-- CXAA012.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 exception Mode_Error is raised when an attempt is made +-- to read from (perform a Get_Line) or use the predefined End_Of_File +-- function on a text file with mode Append_File. +-- +-- TEST DESCRIPTION: +-- A scenario is created that demonstrates the potential for the +-- incorrect usage of predefined text processing subprograms, resulting +-- from their use with files of the wrong Mode. This results in the +-- raising of Mode_Error exceptions, which is handled within blocks +-- embedded in the test. +-- A count is kept to ensure that each anticipated exception is in fact +-- raised and handled properly. +-- +-- APPLICABILITY CRITERIA: +-- This test is applicable only to implementations that support text +-- files. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 27 Feb 97 PWB.CTA Allowed for non-support of some IO operations +--! + +with Ada.Text_IO; +with Report; + +procedure CXAA012 is + use Ada; + Text_File : Text_IO.File_Type; + Text_Filename : constant String := + Report.Legal_File_Name ( Nam => "CXAA012" ); + Incomplete : exception; +begin + + Report.Test ("CXAA012", "Check that the exception Mode_Error is " & + "raised when an attempt is made to read " & + "from (perform a Get_Line) or use the " & + "predefined End_Of_File function on a " & + "text file with mode Append_File"); + + Test_for_Text_IO_Support: + begin + + -- Use_Error or Name_Error will be raised if Text_IO operations + -- or external files are not supported. + + Text_IO.Create (Text_File, Text_IO.Out_File, Text_Filename); + + exception + when Text_IO.Use_Error | Text_IO.Name_Error => + Report.Not_Applicable + ( "Files not supported - Create as Out_File for Text_IO" ); + raise Incomplete; + end Test_for_Text_IO_Support; + + -- The application writes some amount of data to the file. + + Text_IO.Put_Line (Text_File, "Data entered into the file"); + + Text_IO.Close (Text_File); + + Operational_Test_Block: + declare + TC_Number_Of_Forced_Mode_Errors : constant Natural := 2; + TC_Mode_Errors : Natural := 0; + begin + + Text_IO.Open (Text_File, Text_IO.Append_File, Text_Filename); + + Test_for_Reading: + declare + TC_Data : String (1..80); + TC_Length : Natural := 0; + begin + +-- During the course of its processing, the application may become confused +-- and erroneously attempt to read data from the file that is currently in +-- Append_File mode (instead of the anticipated In_File mode). +-- This would result in the raising of Mode_Error. + + Text_IO.Get_Line (Text_File, TC_Data, TC_Length); + Report.Failed ("Exception not raised by Get_Line"); + +-- An exception handler present within the application handles the exception +-- and processing can continue. + + exception + when Text_IO.Mode_Error => + TC_Mode_Errors := TC_Mode_Errors + 1; + when others => + Report.Failed ("Exception in Get_Line processing"); + end Test_for_Reading; + + + Test_for_End_Of_File: + declare + TC_End_Of_File : Boolean; + begin + +-- Again, during the course of its processing, the application attempts to +-- call the End_Of_File function for the file that is currently in +-- Append_File mode (instead of the anticipated In_File mode). + + TC_End_Of_File := Text_IO.End_Of_File (Text_File); + Report.Failed ("Exception not raised by End_Of_File"); + +-- Once again, an exception handler present within the application handles +-- the exception and processing continues. + + exception + when Text_IO.Mode_Error => + TC_Mode_Errors := TC_Mode_Errors + 1; + when others => + Report.Failed("Exception in End_Of_File processing"); + end Test_for_End_Of_File; + + + if (TC_Mode_Errors /= TC_Number_Of_Forced_Mode_Errors) then + Report.Failed ("Incorrect number of exceptions handled"); + end if; + + end Operational_Test_Block; + + -- Delete the external file. + if Text_IO.Is_Open (Text_File) then + Text_IO.Delete (Text_File); + else + Text_IO.Open (Text_File, Text_IO.In_File, Text_Filename); + Text_IO.Delete (Text_File); + end if; + + Report.Result; + +exception + when Incomplete => + Report.Result; + when others => + Report.Failed ( "Unexpected exception" ); + Report.Result; + +end CXAA012; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa013.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa013.a new file mode 100644 index 000000000..be658ca13 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxaa013.a @@ -0,0 +1,167 @@ +-- CXAA013.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 exception Mode_Error is raised when an attempt is made +-- to skip a line or page using the predefined Skip_Line and Skip_Page +-- procedures on a text file with mode Append_File. +-- +-- TEST DESCRIPTION: +-- A scenario is created that demonstrates the potential for the +-- incorrect usage of predefined text processing subprograms, which +-- results in the raising of a Mode_Error exception. +-- A count is kept to ensure that each anticipated exception is in fact +-- raised and handled properly. +-- +-- APPLICABILITY CRITERIA: +-- This test is applicable only to implementations that support text +-- files. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 28 Feb 97 PWB.CTA Allowed for non-support of some IO operations +--! + +with Ada.Text_IO; +with Report; + +procedure CXAA013 is + use Ada; + Text_File : Text_IO.File_Type; + Text_Filename : constant String := + Report.Legal_File_Name ( Nam => "CXAA013" ); + Incomplete : exception; + +begin + + Report.Test ("CXAA013", "Check that the exception Mode_Error is " & + "raised when an attempt is made to skip " & + "a line or page using the predefined " & + "Skip_Line and Skip_Page procedures on " & + "a text file with mode Append_File"); + + Test_for_Text_IO_Support: + begin + +-- An application creates a text file with mode Append_File. +-- Use_Error will be raised if Text_IO operations or external files are not +-- supported. + + Text_IO.Create (Text_File, Text_IO.Append_File, Text_Filename); + + exception + + when Text_IO.Use_Error | Text_IO.Name_Error => + Report.Not_Applicable + ( "Files not supported - Create as Append_File for Text_IO" ); + raise Incomplete; + + end Test_for_Text_IO_Support; + +-- The application writes some amount of data to the file. + + Text_IO.Put_Line (Text_File, "Data entered into the file"); + + Operational_Test_Block: + declare + TC_Number_Of_Forced_Mode_Errors : constant Natural := 2; + TC_Mode_Errors : Natural := 0; + begin + + Test_for_Skip_Line: + declare + TC_Spacing : constant Text_IO.Count := 3; + begin + +-- During the course of its processing, the application may attempt to +-- invoke the Skip_Line procedure on a file that is currently in Append_File +-- mode (instead of the anticipated In_File mode). This results in the +-- raising of Mode_Error. + + Text_IO.Skip_Line (Text_File, TC_Spacing); + Report.Failed ("Exception not raised by Skip_Line"); + +-- An exception handler present within the application handles the exception +-- and processing can continue. + + exception + when Text_IO.Mode_Error => + TC_Mode_Errors := TC_Mode_Errors + 1; + when others => + Report.Failed("Exception in Skip_Line processing"); + end Test_for_Skip_Line; + + Test_for_Skip_Page: + begin + +-- Again, during the course of its processing, the application incorrectly +-- assumes that the file mode is In_File, this time attempting to call the +-- Skip_Page procedure for the file (that is currently in Append_File mode). + + Text_IO.Skip_Page (Text_File); + Report.Failed ("Exception not raised by Skip_Page"); + +-- Once again, an exception handler present within the application handles +-- the exception and processing continues. + + exception + when Text_IO.Mode_Error => + TC_Mode_Errors := TC_Mode_Errors + 1; + when others => + Report.Failed("Exception in Skip_Page processing"); + end Test_for_Skip_Page; + + if (TC_Mode_Errors /= TC_Number_Of_Forced_Mode_Errors) then + Report.Failed ("Incorrect number of exceptions handled"); + end if; + + end Operational_Test_Block; + + Deletion: + begin + -- Delete the external file. + if Text_IO.Is_Open (Text_File) then + Text_IO.Delete (Text_File); + else + Text_IO.Open (Text_File, Text_IO.In_File, Text_Filename); + Text_IO.Delete (Text_File); + end if; + exception + when others => + Report.Failed + ( "Delete not properly implemented for Text_IO" ); + end Deletion; + + Report.Result; + +exception + when Incomplete => + Report.Result; + when others => + Report.Failed ( "Unexpected exception" ); + Report.Result; + +end CXAA013; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa014.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa014.a new file mode 100644 index 000000000..0b74c6169 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxaa014.a @@ -0,0 +1,178 @@ +-- CXAA014.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 exception Mode_Error is raised when an attempt is made +-- to check for the end of a line or page using the predefined functions +-- End_Of_Line or End_Of_Page on a text file with mode Append_File. +-- +-- TEST DESCRIPTION: +-- A scenario is created that demonstrates the potential for the +-- incorrect usage of predefined text processing subprograms, which +-- results in the raising of a Mode_Error exception. +-- A count is kept to ensure that each anticipated exception is in fact +-- raised and handled properly. +-- +-- APPLICABILITY CRITERIA: +-- This test is applicable only to implementations that support text +-- files. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 28 Feb 97 PWB.CTA Allowed for non-support of some IO operations +--! + +with Ada.Text_IO; +with Report; + +procedure CXAA014 is + use Ada; + Text_File : Text_IO.File_Type; + Text_Filename : constant String := + Report.Legal_File_Name ( Nam => "CXAA014" ); + Incomplete : exception; + +begin + + Report.Test ("CXAA014", "Check that the exception Mode_Error is " & + "raised when an attempt is made to check " & + "for the end of a line or page using the " & + "predefined functions End_Of_Line or " & + "End_Of_Page on a text file with mode " & + "Append_File"); + + Test_for_Text_IO_Support: + begin + +-- Use_Error will be raised if Text_IO operations or external files are not +-- supported. + + Text_IO.Create (Text_File, Text_IO.Out_File, Text_Filename); + + exception + + when Text_IO.Use_Error | Text_IO.Name_Error => + Report.Not_Applicable + ( "Files not supported - Create as Out_File for Text_IO" ); + raise Incomplete; + + end Test_for_Text_IO_Support; + + +-- The application writes some amount of data to the file. + + for I in 1 .. 10 loop + Text_IO.Put_Line (Text_File, "Data entered into the file"); + end loop; + + Text_IO.Close (Text_File); + + Operational_Test_Block: + declare + TC_Number_Of_Forced_Mode_Errors : constant Natural := 2; + TC_Mode_Errors : Natural := 0; + begin + + Text_IO.Open (Text_File, Text_IO.Append_File, Text_Filename); + + Test_for_End_Of_Line: + declare + TC_End_Of_Line : Boolean; + begin + +-- During the course of its processing, the application may attempt to +-- invoke the End_Of_Line function on a file that is currently in Append_File +-- mode (instead of the anticipated In_File mode). This results in the +-- raising of Mode_Error. + + TC_End_Of_Line := Text_IO.End_Of_Line (Text_File); + Report.Failed ("Exception not raised by End_Of_Line"); + +-- An exception handler present within the application handles the exception +-- and processing can continue. + + exception + when Text_IO.Mode_Error => + TC_Mode_Errors := TC_Mode_Errors + 1; + when others => + Report.Failed("Exception in End_Of_Line processing"); + end Test_for_End_Of_Line; + + + Test_for_End_Of_Page: + declare + TC_End_Of_Page : Boolean; + begin + +-- Again, during the course of its processing, the application incorrectly +-- assumes that the file mode is In_File, this time attempting to call the +-- End_Of_Page function for the file (that is currently in Append_File mode). + + TC_End_Of_Page := Text_IO.End_Of_Page (Text_File); + Report.Failed ("Exception not raised by End_Of_Page"); + +-- Once again, an exception handler present within the application handles +-- the exception and processing continues. + + exception + when Text_IO.Mode_Error => + TC_Mode_Errors := TC_Mode_Errors + 1; + when others => + Report.Failed("Exception in End_Of_Page processing"); + end Test_for_End_Of_Page; + + + if (TC_Mode_Errors /= TC_Number_Of_Forced_Mode_Errors) then + Report.Failed ("Incorrect number of exceptions handled"); + end if; + + end Operational_Test_Block; + + Deletion: + begin + -- Delete the external file. + if Text_IO.Is_Open (Text_File) then + Text_IO.Delete (Text_File); + else + Text_IO.Open (Text_File, Text_IO.In_File, Text_Filename); + Text_IO.Delete (Text_File); + end if; + exception + when others => + Report.Failed + ( "Delete not properly implemented for Text_IO" ); + end Deletion; + + Report.Result; + +exception + when Incomplete => + Report.Result; + when others => + Report.Failed ( "Unexpected exception" ); + Report.Result; + +end CXAA014; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa015.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa015.a new file mode 100644 index 000000000..919ef05ca --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxaa015.a @@ -0,0 +1,227 @@ +-- CXAA015.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 exception Status_Error is raised when an attempt is +-- made to create or open a file in Append_File mode when the file is +-- already open. +-- Check that the exception Name_Error is raised by procedure Open when +-- attempting to open a file in Append_File mode when the name supplied +-- as the filename does not correspond to an existing external file. +-- +-- TEST DESCRIPTION: +-- A scenario is created that demonstrates the potential for the +-- inappropriate usage of text processing subprograms Create and Open, +-- resulting in the raising of Status_Error and Name_Error exceptions. +-- A count is kept to ensure that each anticipated exception is in fact +-- raised and handled properly. +-- +-- APPLICABILITY CRITERIA: +-- This test is applicable only to implementations that support text +-- files. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 28 Feb 97 PWB.CTA Allowed for non-support of some IO operations +--! + +with Ada.Text_IO; +with Report; + +procedure CXAA015 is + use Ada; + Text_File : Text_IO.File_Type; + Text_Filename : constant String := + Report.Legal_File_Name ( Nam => "CXAA015" ); + Incomplete : exception; + +begin + + Report.Test ("CXAA015", "Check that the appropriate exceptions " & + "are raised when procedures Create and " & + "Open are used to inappropriately operate " & + "on files of mode Append_File"); + + Test_for_Text_IO_Support: + begin + +-- An application creates a text file with mode Append_File. +-- Use_Error will be raised if Text_IO operations or external files are not +-- supported. + + Text_IO.Create (Text_File, Text_IO.Append_File, Text_Filename); + exception + + when Text_IO.Use_Error | Text_IO.Name_Error => + Report.Not_Applicable + ( "Files not supported - Create as Append_File for Text_IO" ); + raise Incomplete; + + end Test_for_Text_IO_Support; + + +-- The application writes some amount of data to the file. + + for I in 1 .. 5 loop + Text_IO.Put_Line (Text_File, "Data entered into the file"); + end loop; + + Operational_Test_Block: + declare + TC_Number_Of_Forced_Errors : constant Natural := 3; + TC_Errors : Natural := 0; + begin + + + Test_for_Create: + begin + +-- During the course of its processing, the application may (erroneously) +-- attempt to create the same file already in existence in Append_File mode. +-- This results in the raising of Status_Error. + + Text_IO.Create (Text_File, + Text_IO.Append_File, + Text_Filename); + Report.Failed ("Exception not raised by Create"); + +-- An exception handler present within the application handles the exception +-- and processing can continue. + + exception + when Text_IO.Status_Error => + TC_Errors := TC_Errors + 1; + when others => + Report.Failed("Exception in Create processing"); + end Test_for_Create; + + + First_Test_For_Open: + begin + +-- Again, during the course of its processing, the application incorrectly +-- attempts to Open a file (in Append_File mode) that is already open. + + Text_IO.Open (Text_File, Text_IO.Append_File, Text_Filename); + Report.Failed ("Exception not raised by improper Open - 1"); + +-- Once again, an exception handler present within the application handles +-- the exception and processing continues. + + exception + when Text_IO.Status_Error => + TC_Errors := TC_Errors + 1; + +-- At some point in its processing, the application closes the file that is +-- currently open. + + Text_IO.Close (Text_File); + when others => + Report.Failed("Exception in Open processing - 1"); + end First_Test_For_Open; + + + Open_With_Wrong_Filename: + declare + TC_Wrong_Filename : constant String := + Report.Legal_File_Name(2); + begin + +-- At this point, the application attempts to Open (in Append_File mode) the +-- file used in previous processing, but it attempts this Open using a name +-- string that does not correspond to any existing external file. +-- First make sure the file doesn't exist. (If it did, then the check +-- for open in append mode wouldn't work.) + + Verify_No_File: + begin + Text_IO.Open (Text_File, + Text_IO.In_File, + TC_Wrong_Filename); + exception + when Text_IO.Name_Error => + null; + when others => + Report.Failed ( "Unexpected exception on Open check" ); + end Verify_No_File; + + Delete_No_File: + begin + if Text_IO.Is_Open (Text_File) then + Text_IO.Delete (Text_File); + end if; + exception + when others => + Report.Failed ( "Unexpected exception - Delete check" ); + end Delete_No_File; + + Text_IO.Open (Text_File, + Text_IO.Append_File, + TC_Wrong_Filename); + Report.Failed ("Exception not raised by improper Open - 2"); + +-- An exception handler for the Name_Error, present within the application, +-- catches the exception and processing continues. + + exception + when Text_IO.Name_Error => + TC_Errors := TC_Errors + 1; + when others => + Report.Failed("Exception in Open processing - 2"); + end Open_With_Wrong_Filename; + + + if (TC_Errors /= TC_Number_Of_Forced_Errors) then + Report.Failed ("Incorrect number of exceptions handled"); + end if; + + end Operational_Test_Block; + + Deletion: + begin + -- Delete the external file. + if Text_IO.Is_Open (Text_File) then + Text_IO.Delete (Text_File); + else + Text_IO.Open (Text_File, Text_IO.In_File, Text_Filename); + Text_IO.Delete (Text_File); + end if; + exception + when others => + Report.Failed + ( "Delete not properly implemented for Text_IO" ); + end Deletion; + + Report.Result; + +exception + when Incomplete => + Report.Result; + when others => + Report.Failed ( "Unexpected exception" ); + Report.Result; + +end CXAA015; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa016.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa016.a new file mode 100644 index 000000000..8ae69a126 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxaa016.a @@ -0,0 +1,462 @@ +-- CXAA016.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 type File_Access is available in Ada.Text_IO, and that +-- objects of this type designate File_Type objects. +-- Check that function Set_Error will set the current default error file. +-- Check that versions of Ada.Text_IO functions Standard_Input, +-- Standard_Output, Standard_Error return File_Access values designating +-- the standard system input, output, and error files. +-- Check that versions of Ada.Text_IO functions Current_Input, +-- Current_Output, Current_Error return File_Access values designating +-- the current system input, output, and error files. +-- +-- TEST DESCRIPTION: +-- This test tests the use of File_Access objects in referring +-- to File_Type objects, as well as several new functions that return +-- File_Access objects as results. +-- Four user-defined files are created. These files will be set to +-- function as current system input, output, and error files. +-- Data will be read from and written to these files during the +-- time at which they function as the current system files. +-- An array of File_Access objects will be defined. It will be +-- initialized using functions that return File_Access objects +-- referencing the Standard and Current Input, Output, and Error files. +-- This "saves" the initial system environment, which will be modified +-- to use the user-defined files as the current default Input, Output, +-- and Error files. At the end of the test, the data in this array +-- will be used to restore the initial system environment. +-- +-- APPLICABILITY CRITERIA: +-- This test is applicable to implementations capable of supporting +-- external Text_IO files. +-- +-- +-- CHANGE HISTORY: +-- 25 May 95 SAIC Initial prerelease version. +-- 22 Apr 96 SAIC Incorporated reviewer comments for ACVC 2.1. +-- 26 Feb 97 PWB.CTA Allowed for non-support of some IO operations. +-- 18 Jan 99 RLB Repaired to allow Not_Applicable systems to +-- fail delete. +--! + +with Ada.Text_IO; +package CXAA016_0 is + New_Input_File, + New_Output_File, + New_Error_File_1, + New_Error_File_2 : aliased Ada.Text_IO.File_Type; +end CXAA016_0; + + +with Report; +with Ada.Exceptions; +with Ada.Text_IO; use Ada.Text_IO; +with CXAA016_0; use CXAA016_0; + +procedure CXAA016 is + + Non_Applicable_System : exception; + No_Reset : exception; + Not_Applicable_System : Boolean := False; + + procedure Delete_File ( A_File : in out Ada.Text_IO.File_Type; + ID_Num : in Integer ) is + begin + if not Ada.Text_IO.Is_Open ( A_File ) then + Ada.Text_IO.Open ( A_File, + Ada.Text_IO.In_File, + Report.Legal_File_Name ( ID_Num ) ); + end if; + Ada.Text_IO.Delete ( A_File ); + exception + when Ada.Text_IO.Name_Error => + if Not_Applicable_System then + null; -- File probably wasn't created. + else + Report.Failed ( "Can't open file for Text_IO" ); + end if; + when Ada.Text_IO.Use_Error => + if Not_Applicable_System then + null; -- File probably wasn't created. + else + Report.Failed ( "Delete not properly implemented for Text_IO" ); + end if; + when others => + Report.Failed ( "Unexpected exception in Delete_File" ); + end Delete_File; + +begin + + Report.Test ("CXAA016", "Check that the type File_Access is available " & + "in Ada.Text_IO, and that objects of this " & + "type designate File_Type objects"); + Test_Block: + declare + + use Ada.Exceptions; + + type System_File_Array_Type is + array (Integer range <>) of File_Access; + + -- Fill the following array with the File_Access results of six + -- functions. + + Initial_Environment : System_File_Array_Type(1..6) := + ( Standard_Input, + Standard_Output, + Standard_Error, + Current_Input, + Current_Output, + Current_Error ); + + New_Input_Ptr : File_Access := New_Input_File'Access; + New_Output_Ptr : File_Access := New_Output_File'Access; + New_Error_Ptr : File_Access := New_Error_File_1'Access; + + Line : String(1..80); + Length : Natural := 0; + + Line_1 : constant String := "This is the first line in the Output file"; + Line_2 : constant String := "This is the next line in the Output file"; + Line_3 : constant String := "This is the first line in Error file 1"; + Line_4 : constant String := "This is the next line in Error file 1"; + Line_5 : constant String := "This is the first line in Error file 2"; + Line_6 : constant String := "This is the next line in Error file 2"; + + + + procedure New_File (The_File : in out File_Type; + Mode : in File_Mode; + Next : in Integer) is + begin + Create (The_File, Mode, Report.Legal_File_Name(Next)); + exception + -- The following two exceptions may be raised if a system is not + -- capable of supporting external Text_IO files. The handler will + -- raise a user-defined exception which will result in a + -- Not_Applicable result for the test. + when Use_Error | Name_Error => raise Non_Applicable_System; + end New_File; + + + + procedure Check_Initial_Environment (Env : System_File_Array_Type) is + begin + -- Check that the system has defined the following sources/ + -- destinations for input/output/error, and that the six functions + -- returning File_Access values are available. + if not (Env(1) = Standard_Input and + Env(2) = Standard_Output and + Env(3) = Standard_Error and + Env(4) = Current_Input and + Env(5) = Current_Output and + Env(6) = Current_Error) + then + Report.Failed("At the start of the test, the Standard and " & + "Current File_Access values associated with " & + "system Input, Output, and Error files do " & + "not correspond"); + end if; + end Check_Initial_Environment; + + + + procedure Load_Input_File (Input_Ptr : in File_Access) is + begin + -- Load data into the file that will function as the user-defined + -- system input file. + Put_Line(Input_Ptr.all, Line_1); + Put_Line(Input_Ptr.all, Line_2); + Put_Line(Input_Ptr.all, Line_3); + Put_Line(Input_Ptr.all, Line_4); + Put_Line(Input_Ptr.all, Line_5); + Put_Line(Input_Ptr.all, Line_6); + end Load_Input_File; + + + + procedure Restore_Initial_Environment + (Initial_Env : System_File_Array_Type) is + begin + -- Restore the Current Input, Output, and Error files to their + -- original states. + + Set_Input (Initial_Env(4).all); + Set_Output(Initial_Env(5).all); + Set_Error (Initial_Env(6).all); + + -- At this point, the user-defined files that were functioning as + -- the Current Input, Output, and Error files have been replaced in + -- that capacity by the state of the original environment. + + declare + + -- Capture the state of the current environment. + + Current_Env : System_File_Array_Type (1..6) := + (Standard_Input, Standard_Output, Standard_Error, + Current_Input, Current_Output, Current_Error); + begin + + -- Compare the current environment with that of the saved + -- initial environment. + + if Current_Env /= Initial_Env then + Report.Failed("Restored file environment was not the same " & + "as the initial file environment"); + end if; + end; + end Restore_Initial_Environment; + + + + procedure Verify_Files (O_File, E_File_1, E_File_2 : in File_Type) is + Str_1, Str_2, Str_3, Str_4, Str_5, Str_6 : String (1..80); + Len_1, Len_2, Len_3, Len_4, Len_5, Len_6 : Natural; + begin + + -- Get the lines that are contained in all the files, and verify + -- them against the expected results. + + Get_Line(O_File, Str_1, Len_1); -- The user defined output file + Get_Line(O_File, Str_2, Len_2); -- should contain two lines of data. + + if Str_1(1..Len_1) /= Line_1 or + Str_2(1..Len_2) /= Line_2 + then + Report.Failed("Incorrect results from Current_Output file"); + end if; + + Get_Line(E_File_1, Str_3, Len_3); -- The first error file received + Get_Line(E_File_1, Str_4, Len_4); -- two lines of data originally, + Get_Line(E_File_1, Str_5, Len_5); -- then had two additional lines + Get_Line(E_File_1, Str_6, Len_6); -- appended from the second error + -- file. + if Str_3(1..Len_3) /= Line_3 or + Str_4(1..Len_4) /= Line_4 or + Str_5(1..Len_5) /= Line_5 or + Str_6(1..Len_6) /= Line_6 + then + Report.Failed("Incorrect results from first Error file"); + end if; + + Get_Line(E_File_2, Str_5, Len_5); -- The second error file + Get_Line(E_File_2, Str_6, Len_6); -- received two lines of data. + + if Str_5(1..Len_5) /= Line_5 or + Str_6(1..Len_6) /= Line_6 + then + Report.Failed("Incorrect results from second Error file"); + end if; + + end Verify_Files; + + + + begin + + Check_Initial_Environment (Initial_Environment); + + -- Create user-defined text files that will be set to serve as current + -- system input, output, and error files. + + New_File (New_Input_File, Out_File, 1); -- Will be reset prior to use. + New_File (New_Output_File, Out_File, 2); + New_File (New_Error_File_1, Out_File, 3); + New_File (New_Error_File_2, Out_File, 4); + + -- Enter several lines of text into the new input file. This file will + -- be reset to mode In_File to function as the current system input file. + -- Note: File_Access value used as parameter to this procedure. + + Load_Input_File (New_Input_Ptr); + + -- Reset the New_Input_File to mode In_File, to allow it to act as the + -- current system input file. + + Reset1: + begin + Reset (New_Input_File, In_File); + exception + when Ada.Text_IO.Use_Error => + Report.Not_Applicable + ( "Reset to In_File not supported for Text_IO - 1" ); + raise No_Reset; + end Reset1; + + -- Establish new files that will function as the current system Input, + -- Output, and Error files. + + Set_Input (New_Input_File); + Set_Output(New_Output_Ptr.all); + Set_Error (New_Error_Ptr.all); + + -- Perform various file processing tasks, exercising specific new + -- Text_IO functionality. + -- + -- Read two lines from Current_Input and write them to Current_Output. + + for i in 1..2 loop + Get_Line(Current_Input, Line, Length); + Put_Line(Current_Output, Line(1..Length)); + end loop; + + -- Read two lines from Current_Input and write them to Current_Error. + + for i in 1..2 loop + Get_Line(Current_Input, Line, Length); + Put_Line(Current_Error, Line(1..Length)); + end loop; + + -- Reset the Current system error file. + + Set_Error (New_Error_File_2); + + -- Read two lines from Current_Input and write them to Current_Error. + + for i in 1..2 loop + Get_Line(Current_Input, Line, Length); + Put_Line(Current_Error, Line(1..Length)); + end loop; + + -- At this point in the processing, the new Output file, and each of + -- the two Error files, contain two lines of data. + -- Note that New_Error_File_1 has been replaced by New_Error_File_2 + -- as the current system error file, allowing New_Error_File_1 to be + -- reset (Mode_Error raised otherwise). + -- + -- Reset the first Error file to Append_File mode, and then set it to + -- function as the current system error file. + + Reset2: + begin + Reset (New_Error_File_1, Append_File); + exception + when Ada.Text_IO.Use_Error => + Report.Not_Applicable + ( "Reset to Append_File not supported for Text_IO - 2" ); + raise No_Reset; + end Reset2; + + Set_Error (New_Error_File_1); + + -- Reset the second Error file to In_File mode, then set it to become + -- the current system input file. + + Reset3: + begin + Reset (New_Error_File_2, In_File); + exception + when Ada.Text_IO.Use_Error => + Report.Not_Applicable + ( "Reset to In_File not supported for Text_IO - 3" ); + raise No_Reset; + end Reset3; + + New_Error_Ptr := New_Error_File_2'Access; + Set_Input (New_Error_Ptr.all); + + -- Append all of the text lines (2) in the new current system input + -- file onto the current system error file. + + while not End_Of_File(Current_Input) loop + Get_Line(Current_Input, Line, Length); + Put_Line(Current_Error, Line(1..Length)); + end loop; + + -- Restore the original system file environment, based upon the values + -- stored at the start of this test. + -- Check that the original environment has been restored. + + Restore_Initial_Environment (Initial_Environment); + + -- Reset all three files to In_File_Mode prior to verification. + -- Note: If these three files had still been the designated Current + -- Input, Output, or Error files for the system, a Reset + -- operation at this point would raise Mode_Error. + -- However, at this point, the environment has been restored to + -- its original state, and these user-defined files are no longer + -- designated as current system files, allowing a Reset. + + Reset4: + begin + Reset(New_Error_File_1, In_File); + exception + when Ada.Text_IO.Use_Error => + Report.Not_Applicable + ( "Reset to In_File not supported for Text_IO - 4" ); + raise No_Reset; + end Reset4; + + Reset5: + begin + Reset(New_Error_File_2, In_File); + exception + when Ada.Text_IO.Use_Error => + Report.Not_Applicable + ( "Reset to In_File not supported for Text_IO - 5" ); + raise No_Reset; + end Reset5; + + Reset6: + begin + Reset(New_Output_File, In_File); + exception + when Ada.Text_IO.Use_Error => + Report.Not_Applicable + ( "Reset to In_File not supported for Text_IO - 6" ); + raise No_Reset; + end Reset6; + + -- Check that all the files contain the appropriate data. + + Verify_Files (New_Output_File, New_Error_File_1, New_Error_File_2); + + exception + when No_Reset => + null; + when Non_Applicable_System => + Report.Not_Applicable("System not capable of supporting external " & + "text files -- Name_Error/Use_Error raised " & + "during text file creation"); + Not_Applicable_System := True; + when The_Error : others => + Report.Failed ("The following exception was raised in the " & + "Test_Block: " & Exception_Name(The_Error)); + end Test_Block; + + Delete_Block: + begin + Delete_File ( New_Input_File, 1 ); + Delete_File ( New_Output_File, 2 ); + Delete_File ( New_Error_File_1, 3 ); + Delete_File ( New_Error_File_2, 4 ); + end Delete_Block; + + Report.Result; + +end CXAA016; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa017.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa017.a new file mode 100644 index 000000000..17d0922cc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxaa017.a @@ -0,0 +1,400 @@ +-- CXAA017.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 Ada.Text_IO function Look_Ahead sets parameter End_Of_Line +-- to True if at the end of a line; otherwise check that it returns the +-- next character from a file (without consuming it), while setting +-- End_Of_Line to False. +-- +-- Check that Ada.Text_IO function Get_Immediate will return the next +-- control or graphic character in parameter Item from the specified +-- file. Check that the version of Ada.Text_IO function Get_Immediate +-- with the Available parameter will, if a character is available in the +-- specified file, return the character in parameter Item, and set +-- parameter Available to True. +-- +-- TEST DESCRIPTION: +-- This test exercises specific capabilities of two Text_IO subprograms, +-- Look_Ahead and Get_Immediate. A file is prepared that contains a +-- variety of graphic and control characters on several lines. +-- In processing this file, a call to Look_Ahead is performed to ensure +-- that characters are available, then individual characters are +-- extracted from the current line using Get_Immediate. The characters +-- returned from both subprogram calls are compared with the expected +-- character result. Processing on each file line continues until +-- Look_Ahead indicates that the end of the line is next. Separate +-- verification is performed to ensure that all characters of each line +-- are processed, and that the Available and End_Of_Line parameters +-- of the subprograms are properly set in the appropriate instances. +-- +-- APPLICABILITY CRITERIA: +-- This test is applicable to implementations capable of supporting +-- external Text_IO files. +-- +-- +-- CHANGE HISTORY: +-- 30 May 95 SAIC Initial prerelease version. +-- 01 May 96 SAIC Incorporated reviewer comments for ACVC 2.1. +-- 26 Feb 97 PWB.CTA Allowed for non-support of some IO operations. +--! + +with Ada.Text_IO; +package CXAA017_0 is + + User_Defined_Input_File : aliased Ada.Text_IO.File_Type; + +end CXAA017_0; + + +with CXAA017_0; use CXAA017_0; +with Ada.Characters.Latin_1; +with Ada.Exceptions; +with Ada.Text_IO; +with Report; + +procedure CXAA017 is + + use Ada.Characters.Latin_1; + use Ada.Exceptions; + use Ada.Text_IO; + + Non_Applicable_System : exception; + No_Reset : exception; + +begin + + Report.Test ("CXAA017", "Check that Ada.Text_IO subprograms " & + "Look_Ahead and Get_Immediate are available " & + "and produce correct results"); + + Test_Block: + declare + + User_Input_Ptr : File_Access := User_Defined_Input_File'Access; + + UDLA_Char, -- Acronym UDLA => "User Defined Look Ahead" + UDGI_Char, -- Acronym UDGI => "User Defined Get Immediate" + TC_Char : Character := Ada.Characters.Latin_1.NUL; + + UDLA_End_Of_Line, + UDGI_Available : Boolean := False; + + Char_Pos : Natural; + + -- This string contains five ISO 646 Control characters and six ISO 646 + -- Graphic characters: + TC_String_1 : constant String := STX & + SI & + DC2 & + CAN & + US & + Space & + Ampersand & + Solidus & + 'A' & + LC_X & + DEL; + + -- This string contains two ISO 6429 Control and six ISO 6429 Graphic + -- characters: + TC_String_2 : constant String := IS4 & + SCI & + Yen_Sign & + Masculine_Ordinal_Indicator & + UC_I_Grave & + Multiplication_Sign & + LC_C_Cedilla & + LC_Icelandic_Thorn; + + TC_Number_Of_Strings : constant := 2; + + type String_Access_Type is access constant String; + type String_Ptr_Array_Type is + array (1..TC_Number_Of_Strings) of String_Access_Type; + + TC_String_Ptr_Array : String_Ptr_Array_Type := + (new String'(TC_String_1), + new String'(TC_String_2)); + + + + procedure Create_New_File (The_File : in out File_Type; + Mode : in File_Mode; + Next : in Integer) is + begin + Create (The_File, Mode, Report.Legal_File_Name(Next)); + exception + -- The following two exceptions can be raised if a system is not + -- capable of supporting external Text_IO files. The handler will + -- raise a user-defined exception which will result in a + -- Not_Applicable result for the test. + when Use_Error | Name_Error => raise Non_Applicable_System; + end Create_New_File; + + + + procedure Load_File (The_File : in out File_Type) is + -- This procedure will load several strings into the file denoted + -- by the input parameter. A call to New_Line will add line/page + -- termination characters, which will be available for processing + -- along with the text in the file. + begin + Put_Line (The_File, TC_String_Ptr_Array(1).all); + New_Line (The_File, Spacing => 1); + Put_Line (The_File, TC_String_Ptr_Array(2).all); + end Load_File; + + + begin + + -- Create user-defined text file that will serve as the appropriate + -- sources of input to the procedures under test. + + Create_New_File (User_Defined_Input_File, Out_File, 1); + + -- Enter several lines of text into the new input file. + -- The characters that make up these text strings will be processed + -- using the procedures being exercised in this test. + + Load_File (User_Defined_Input_File); + + -- Check that Mode_Error is raised by Look_Ahead and Get_Immedidate + -- if the mode of the file object is not In_File. + -- Currently, the file mode is Out_File. + + begin + Look_Ahead(User_Defined_Input_File, UDLA_Char, UDLA_End_Of_Line); + Report.Failed("Mode_Error not raised by Look_Ahead"); + Report.Comment("This char should never be printed: " & UDLA_Char); + exception + when Mode_Error => null; -- OK, expected exception. + when The_Error : others => + Report.Failed ("The following exception was raised during the " & + "check that Look_Ahead raised Mode_Error when " & + "provided a file object that is not in In_File " & + "mode: " & Exception_Name(The_Error)); + end; + + begin + Get_Immediate(User_Defined_Input_File, UDGI_Char); + Report.Failed("Mode_Error not raised by Get_Immediate"); + Report.Comment("This char should never be printed: " & UDGI_Char); + exception + when Mode_Error => null; -- OK, expected exception. + when The_Error : others => + Report.Failed ("The following exception was raised during the " & + "check that Get_Immediate raised Mode_Error " & + "when provided a file object that is not in " & + "In_File mode: " & Exception_Name(The_Error)); + end; + + + -- The file will then be reset to In_File mode to properly function as + -- a source of input. + + Reset1: + begin + Reset (User_Defined_Input_File, In_File); + exception + when Ada.Text_IO.Use_Error => + Report.Not_Applicable + ( "Reset to In_File not supported for Text_IO" ); + raise No_Reset; + end Reset1; + + -- Process the input file, exercising various Text_IO + -- functionality, and validating the results at each step. + -- Note: The designated File_Access object is used in processing + -- the New_Default_Input_File in the second loop below. + + -- Process characters in first line of text of each file. + + Char_Pos := 1; + + -- Check that the first line is not blank. + + Look_Ahead(User_Defined_Input_File, UDLA_Char, UDLA_End_Of_Line); + + while not UDLA_End_Of_Line loop + + -- Use the Get_Immediate procedure on the file to get the next + -- available character on the current line. + + Get_Immediate(User_Defined_Input_File, UDGI_Char); + + -- Check that the characters returned by both procedures are the + -- same, and that they match the expected character from the file. + + if UDLA_Char /= TC_String_Ptr_Array(1).all(Char_Pos) or + UDGI_Char /= TC_String_Ptr_Array(1).all(Char_Pos) + then + Report.Failed("Incorrect retrieval of character " & + Integer'Image(Char_Pos) & " of first string"); + end if; + + -- Increment the character position counter. + Char_Pos := Char_Pos + 1; + + -- Check the next character on the line. If at the end of line, + -- the processing flow will exit the While loop. + + Look_Ahead(User_Defined_Input_File, UDLA_Char, UDLA_End_Of_Line); + + end loop; + + -- Check to ensure that the "end of line" results returned from the + -- Look_Ahead procedure (used to exit the above While loop) corresponds + -- with the result of Function End_Of_Line. + + if not End_Of_Line(User_Defined_Input_File) + then + Report.Failed("Result of procedure Look_Ahead that indicated " & + "being at the end of the line does not correspond " & + "with the result of function End_Of_Line"); + end if; + + -- Check that all characters in the string were processed. + + if Char_Pos-1 /= TC_String_1'Length then + Report.Failed("Not all of the characters on the first line " & + "were processed"); + end if; + + + -- Call procedure Skip_Line to advance beyond the end of the first line. + + Skip_Line(User_Defined_Input_File); + + + -- Process the second line in the file (a blank line). + + Look_Ahead(User_Input_Ptr.all, UDLA_Char, UDLA_End_Of_Line); + + if not UDLA_End_Of_Line then + Report.Failed("Incorrect end of line determination from procedure " & + "Look_Ahead when processing a blank line"); + end if; + + -- Call procedure Skip_Line to advance beyond the end of the second line. + + Skip_Line(User_Input_Ptr.all); + + + -- Process characters in the third line of the file (second line + -- of text) + -- Note: The version of Get_Immediate used in processing this line has + -- the Boolean parameter Available. + + Char_Pos := 1; + + -- Check whether the line is blank (i.e., at end of line, page, or file). + + Look_Ahead(User_Input_Ptr.all, UDLA_Char, UDLA_End_Of_Line); + + while not UDLA_End_Of_Line loop + + -- Use the Get_Immediate procedure on the file to get access to the + -- next character on the current line. + + Get_Immediate(User_Input_Ptr.all, UDGI_Char, UDGI_Available); + + -- Check that the Available parameter of Get_Immediate was set + -- to indicate that a character was available in the file. + -- Check that the characters returned by both procedures are the + -- same, and they all match the expected character from the file. + + if not UDGI_Available or + UDLA_Char /= TC_String_Ptr_Array(2).all(Char_Pos) or + UDGI_Char /= TC_String_Ptr_Array(2).all(Char_Pos) + then + Report.Failed("Incorrect retrieval of character " & + Integer'Image(Char_Pos) & " of second string"); + end if; + + -- Increment the character position counter. + + Char_Pos := Char_Pos + 1; + + -- Check the next character on the line. If at the end of line, + -- the processing flow will exit the While loop. + + Look_Ahead(User_Input_Ptr.all, UDLA_Char, UDLA_End_Of_Line); + + end loop; + + -- Check to ensure that the "end of line" results returned from the + -- Look_Ahead procedure (used to exit the above While loop) corresponds + -- with the result of Function End_Of_Line. + + if not End_Of_Line(User_Defined_Input_File) + then + Report.Failed("Result of procedure Look_Ahead that indicated " & + "being at the end of the line does not correspond " & + "with the result of function End_Of_Line"); + end if; + + -- Check that all characters in the second string were processed. + + if Char_Pos-1 /= TC_String_2'Length then + Report.Failed("Not all of the characters on the second line " & + "were processed"); + end if; + + + Deletion: + begin + -- Delete the user defined file. + + if Is_Open(User_Defined_Input_File) then + Delete(User_Defined_Input_File); + else + Open(User_Defined_Input_File, Out_File, Report.Legal_File_Name(1)); + Delete(User_Defined_Input_File); + end if; + exception + when others => + Report.Failed + ( "Delete not properly implemented for Text_IO" ); + end Deletion; + + + exception + + when No_Reset => + null; + + when Non_Applicable_System => + Report.Not_Applicable("System not capable of supporting external " & + "text files -- Name_Error/Use_Error raised " & + "during text file creation"); + 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 CXAA017; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa018.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa018.a new file mode 100644 index 000000000..53b16fea4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxaa018.a @@ -0,0 +1,277 @@ +-- CXAA018.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 subprograms defined in the package Text_IO.Modular_IO +-- provide correct results. +-- +-- TEST DESCRIPTION: +-- This test checks that the subprograms defined in the +-- Ada.Text_IO.Modular_IO package provide correct results. +-- A modular type is defined and used to instantiate the generic +-- package Ada.Text_IO.Modular_IO. Values of the modular type are +-- written to a Text_IO file, and to a series of string variables, using +-- different versions of the procedure Put from the instantiated IO +-- package. These modular data items are retrieved from the file and +-- string variables using the appropriate instantiated version of +-- procedure Get. A variety of Base and Width parameter values are +-- used in the procedure calls. +-- +-- APPLICABILITY CRITERIA: +-- This test is applicable to all implementations that support Text_IO +-- processing and external files. +-- +-- +-- CHANGE HISTORY: +-- 03 Jul 95 SAIC Initial prerelease version. +-- 01 May 96 SAIC Incorporated reviewer comments for ACVC 2.1. +-- +--! + +with Ada.Text_IO; +with System; +with Report; + +procedure CXAA018 is +begin + + Report.Test ("CXAA018", "Check that the subprograms defined in " & + "the package Text_IO.Modular_IO provide " & + "correct results"); + + Test_for_Text_IO_Support: + declare + Data_File : Ada.Text_IO.File_Type; + Data_Filename : constant String := Report.Legal_File_Name; + begin + + -- An application creates a text file in mode Out_File, with the + -- intention of entering modular data into the file as appropriate. + -- In the event that the particular environment where the application + -- is running does not support Text_IO, Use_Error or Name_Error will be + -- raised on calls to Text_IO operations. Either of these exceptions + -- will be handled to produce a Not_Applicable result. + + Ada.Text_IO.Create (File => Data_File, + Mode => Ada.Text_IO.Out_File, + Name => Data_Filename); + + Test_Block: + declare + + type Mod_Type is mod System.Max_Binary_Modulus; + -- Max_Binary_Modulus must be at least 2**16, which would result + -- in a base range of 0..65535 (zero to one less than the given + -- modulus) for this modular type. + + package Mod_IO is new Ada.Text_IO.Modular_IO(Mod_Type); + use Ada.Text_IO, Mod_IO; + use type Mod_Type; + + Number_Of_Modular_Items : constant := 6; + Number_Of_Error_Items : constant := 1; + + TC_Modular : Mod_Type; + TC_Last_Character_Read : Positive; + + Modular_Array : array (1..Number_Of_Modular_Items) of Mod_Type := + ( 0, 97, 255, 1025, 12097, 65535 ); + + + procedure Load_File (The_File : in out Ada.Text_IO.File_Type) is + begin + -- This procedure does not create, open, or close the data file; + -- The_File file object must be Open at this point. + -- This procedure is designed to load Modular_Type data into a + -- data file. + -- + -- Use the Modular_IO procedure Put to enter modular data items + -- into the data file. + + for i in 1..Number_Of_Modular_Items loop + -- Use default Base parameter of 10. + Mod_IO.Put(File => Data_File, + Item => Modular_Array(i), + Width => 6, + Base => Mod_IO.Default_Base); + end loop; + + -- Enter data into the file such that on the corresponding "Get" + -- of this data, Data_Error must be raised. This value is outside + -- the base range of Modular_Type. + -- Text_IO is used to enter the value in the file. + + for i in 1..Number_Of_Error_Items loop + Ada.Text_IO.Put(The_File, "-10"); + end loop; + + end Load_File; + + + + procedure Process_File(The_File : in out Ada.Text_IO.File_Type) is + begin + -- This procedure does not create, open, or close the data file; + -- The_File file object must be Open at this point. + -- Use procedure Get (for Files) to extract the modular data from + -- the Text_IO file. + + for i in 1..Number_Of_Modular_Items loop + Mod_IO.Get(The_File, TC_Modular, Width => 6); + + if TC_Modular /= Modular_Array(i) then + Report.Failed("Incorrect modular data read from file " & + "data item #" & Integer'Image(i)); + end if; + end loop; + + -- The final item in the Data_File is a modular value that is + -- outside the base range 0..Num'Last. This value should raise + -- Data_Error on an attempt to "Get" it from the file. + + for i in 1..Number_Of_Error_Items loop + begin + Mod_IO.Get(The_File, TC_Modular, Mod_IO.Default_Width); + Report.Failed + ("Exception Data_Error not raised when Get " & + "was used to read modular data outside base " & + "range of type, item # " & + Integer'Image(i)); + exception + when Ada.Text_IO.Data_Error => + null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised when Get " & + "was used to read modular data outside " & + "base range of type from Data_File, " & + "data item #" & Integer'Image(i)); + end; + end loop; + + exception + when others => + Report.Failed + ("Unexpected exception raised in Process_File"); + end Process_File; + + + + begin -- Test_Block. + + -- Place modular values into data file. + + Load_File(Data_File); + Ada.Text_IO.Close(Data_File); + + -- Read modular values from data file. + + Ada.Text_IO.Open(Data_File, Ada.Text_IO.In_File, Data_Filename); + Process_File(Data_File); + + -- Verify versions of Modular_IO procedures Put and Get for Strings. + + Modular_IO_in_Strings: + declare + TC_String_Array : array (1..Number_Of_Modular_Items) + of String(1..30) := (others =>(others => ' ')); + begin + + -- Place modular values into strings using the Procedure Put, + -- Use a variety of different "Base" parameter values. + -- Note: This version of Put uses the length of the given + -- string as the value of the "Width" parameter. + + for i in 1..2 loop + Mod_IO.Put(To => TC_String_Array(i), + Item => Modular_Array(i), + Base => Mod_IO.Default_Base); + end loop; + for i in 3..4 loop + Mod_IO.Put(TC_String_Array(i), + Modular_Array(i), + Base => 2); + end loop; + for i in 5..6 loop + Mod_IO.Put(TC_String_Array(i), Modular_Array(i), 16); + end loop; + + -- Get modular values from strings using the Procedure Get. + -- Compare with expected modular values. + + for i in 1..Number_Of_Modular_Items loop + + Mod_IO.Get(From => TC_String_Array(i), + Item => TC_Modular, + Last => TC_Last_Character_Read); + + if TC_Modular /= Modular_Array(i) then + Report.Failed("Incorrect modular data value obtained " & + "from String following use of Procedures " & + "Put and Get from Strings, Modular_Array " & + "item #" & Integer'Image(i)); + end if; + end loop; + + exception + when others => + Report.Failed("Unexpected exception raised during the " & + "evaluation of Put and Get for Strings"); + end Modular_IO_in_Strings; + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + + -- Delete the external file. + if Ada.Text_IO.Is_Open(Data_File) then + Ada.Text_IO.Delete(Data_File); + else + Ada.Text_IO.Open(Data_File, + Ada.Text_IO.In_File, + Data_Filename); + Ada.Text_IO.Delete(Data_File); + end if; + + exception + + -- Since Use_Error can be raised if, for the specified mode, + -- the environment does not support Text_IO operations, the + -- following handlers are included: + + when Ada.Text_IO.Use_Error => + Report.Not_Applicable ("Use_Error raised on Text_IO Create"); + + when Ada.Text_IO.Name_Error => + Report.Not_Applicable ("Name_Error raised on Text_IO Create"); + + when others => + Report.Failed ("Unexpected exception raised on text file Create"); + + end Test_for_Text_IO_Support; + + Report.Result; + +end CXAA018; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa019.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa019.a new file mode 100644 index 000000000..04c257e97 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxaa019.a @@ -0,0 +1,138 @@ +-- CXAA019.A +-- +-- Grant of Unlimited Rights +-- +-- The Ada Conformity Assessment Authority (ACAA) holds unlimited +-- rights in the software and documentation contained herein. Unlimited +-- rights are the same as those granted by the U.S. Government for older +-- parts of the Ada Conformity Assessment Test Suite, and are defined +-- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA +-- intends to confer upon all recipients unlimited rights equal to those +-- held by the ACAA. 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 Standard_Output can be flushed. Check that 'in' parameters of +-- types Ada.Text_IO.File_Type and Ada.Streams.Stream_IO.File_Type can be +-- flushed. (Defect Report 8652/0051). +-- +-- CHANGE HISTORY: +-- 12 FEB 2001 PHL Initial version +-- 16 MAR 2001 RLB Readied for release; fixed Not_Applicable check +-- to terminate test gracefully. +-- +--! +with Ada.Streams.Stream_Io; +use Ada.Streams; +with Ada.Text_Io; +with Ada.Wide_Text_Io; +with Report; +use Report; +procedure CXAA019 is + + procedure Check (File : in Ada.Text_Io.File_Type) is + begin + Ada.Text_Io.Put_Line + (File, " - CXAA019 About to flush a Text_IO file passed " & + "as 'in' parameter"); + Ada.Text_Io.Flush (File); + end Check; + + procedure Check (File : in Ada.Wide_Text_Io.File_Type) is + begin + Ada.Wide_Text_Io.Put_Line + (File, " - CXAA019 About to flush a Wide_Text_IO file passed " & + "as 'in' parameter"); + Ada.Wide_Text_Io.Flush (File); + end Check; + + procedure Check (File : in Stream_Io.File_Type) is + S : Stream_Element_Array (1 .. 10); + begin + for I in S'Range loop + S (I) := Stream_Element (Character'Pos ('A') + I); + end loop; + Stream_Io.Write (File, S); + Comment ("About to flush a Stream_IO file passed as 'in' parameter"); + Stream_Io.Flush (File); + end Check; + + +begin + Test ("CXAA019", + "Check that Standard_Output can be flushed; check that " & + "'in' Ada.Text_IO.File_Type and Ada.Streams.Stream_IO.File_Type" & + "parameters can be flushed"); + + Ada.Text_Io.Put_Line (Ada.Text_Io.Standard_Output, + " - CXAA019 About to flush Standard_Output"); + Ada.Text_Io.Flush (Ada.Text_Io.Standard_Output); + + Check (Ada.Text_Io.Current_Output); + + declare + TC_OK : Boolean := False; + F : Ada.Text_Io.File_Type; + begin + begin + Ada.Text_Io.Create (F, Name => Legal_File_Name (X => 1)); + TC_OK := True; + exception + when others => + Not_Applicable ("Unable to create Out mode Text_IO file"); + end; + if TC_OK then + Check (F); + Ada.Text_Io.Delete (F); + end if; + end; + + declare + TC_OK : Boolean := False; + F : Ada.Wide_Text_Io.File_Type; + begin + begin + Ada.Wide_Text_Io.Create (F, Name => Legal_File_Name (X => 2)); + TC_OK := True; + exception + when others => + Not_Applicable ("Unable to create Out mode Wide_Text_IO file"); + end; + if TC_OK then + Check (F); + Ada.Wide_Text_Io.Delete (F); + end if; + end; + + declare + TC_OK : Boolean := False; + F : Stream_Io.File_Type; + begin + begin + Stream_Io.Create (F, Name => Legal_File_Name (X => 3)); + TC_OK := True; + exception + when others => + Not_Applicable ("Unable to create Out mode Stream_IO file"); + end; + if TC_OK then + Check (F); + Stream_Io.Delete (F); + end if; + end; + + Result; +end CXAA019; + diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxab001.a b/gcc/testsuite/ada/acats/tests/cxa/cxab001.a new file mode 100644 index 000000000..483acd16c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxab001.a @@ -0,0 +1,272 @@ +-- CXAB001.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 operations defined in package Wide_Text_IO allow for +-- the input/output of Wide_Character and Wide_String data. +-- +-- TEST DESCRIPTION: +-- This test is designed to exercise the components of the Wide_Text_IO +-- package, including the Put/Get utilities for Wide_Characters and +-- Wide_String objects. +-- The test utilizes the Put and Get procedures defined for +-- Wide_Characters, as well as the Put, Get, Put_Line, and Get_Line +-- procedures defined for Wide_Strings. In addition, many of the +-- additional subprograms found in package Wide_Text_IO are used in this +-- test. +-- +-- APPLICABILITY CRITERIA: +-- This test is applicable to all implementations capable of supporting +-- external Wide_Text_IO files. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 26 Feb 97 CTA.PWB Allowed for non-support of some IO operations. +--! + +with Ada.Wide_Text_IO; +with Report; + +procedure CXAB001 is + + Filter_File : Ada.Wide_Text_IO.File_Type; + Filter_Filename : constant String := + Report.Legal_File_Name ( Nam => "CXAB001" ); + Incomplete : exception; + + +begin + + Report.Test ("CXAB001", "Check that the operations defined in package " & + "Wide_Text_IO allow for the input/output of " & + "Wide_Character and Wide_String data"); + + + Test_for_Wide_Text_IO_Support: + begin + + -- An implementation that does not support Wide_Text_IO in a particular + -- environment will raise Use_Error on calls to various + -- Wide_Text_IO operations. This block statement encloses a call to + -- Create, which should raise an exception in a non-supportive + -- environment. This exception will be handled to produce a + -- Not_Applicable result. + + Ada.Wide_Text_IO.Create (File => Filter_File, -- Create. + Mode => Ada.Wide_Text_IO.Out_File, + Name => Filter_Filename); + + exception + + when Ada.Wide_Text_IO.Use_Error | Ada.Wide_Text_IO.Name_Error => + Report.Not_Applicable + ( "Files not supported - Create as Out_File for Wide_Text_IO" ); + raise Incomplete; + + end Test_for_Wide_Text_IO_Support; + + Operational_Test_Block: + declare + + First_String : constant Wide_String := "Somewhere "; + Second_String : constant Wide_String := "Over The "; + Third_String : constant Wide_String := "Rainbow"; + Current_Char : Wide_Character := ' '; + + begin + + Enter_Data_In_File: + declare + Pos : Natural := 1; + Bad_Character_Found : Boolean := False; + begin + -- Use the Put procedure defined for Wide_Character data to + -- write all of the wide characters of the First_String into + -- the file individually, followed by a call to New_Line. + + while Pos <= First_String'Length loop + Ada.Wide_Text_IO.Put (Filter_File, First_String (Pos)); -- Put. + Pos := Pos + 1; + end loop; + Ada.Wide_Text_IO.New_Line (Filter_File); -- New_Line. + + -- Reset to In_File mode and read file contents, using the Get + -- procedure defined for Wide_Character data. + Reset1: + begin + Ada.Wide_Text_IO.Reset (Filter_File, -- Reset. + Ada.Wide_Text_IO.In_File); + exception + when Ada.Wide_Text_IO.Use_Error => + Report.Not_Applicable + ( "Reset to In_File not supported for Wide_Text_IO" ); + raise Incomplete; + end Reset1; + + Pos := 1; + while Pos <= First_String'Length loop + Ada.Wide_Text_IO.Get (Filter_File, Current_Char); -- Get. + -- Verify the wide character against the original string. + if Current_Char /= First_String(Pos) then + Bad_Character_Found := True; + end if; + Pos := Pos + 1; + end loop; + + if Bad_Character_Found then + Report.Failed ("Incorrect Wide_Character read from file - 1"); + end if; + + -- Following user file/string processing, the Wide_String data + -- of the Second_String and Third_String Wide_String objects are + -- appended to the file. + -- The Put procedure defined for Wide_String data is used to + -- transfer the Second_String, followed by a call to New_Line. + -- The Put_Line procedure defined for Wide_String data is used + -- to transfer the Third_String. + Reset2: + begin + Ada.Wide_Text_IO.Reset (Filter_File, -- Reset. + Ada.Wide_Text_IO.Append_File); + + exception + when Ada.Wide_Text_IO.Use_Error => + Report.Not_Applicable + ( "Reset to Append_File not supported for Wide_Text_IO" ); + raise Incomplete; + end Reset2; + + Ada.Wide_Text_IO.Put (Filter_File, Second_String); -- Put. + Ada.Wide_Text_IO.New_Line (Filter_File); -- New_Line. + + Ada.Wide_Text_IO.Put_Line (Filter_File, Third_String); -- Put_Line. + Ada.Wide_Text_IO.Close (Filter_File); -- Close. + + exception + + when Incomplete => + raise; + + when others => + Report.Failed ("Exception in Enter_Data_In_File block"); + raise; + + end Enter_Data_In_File; + + --- + + Filter_Block: + declare + + Pos : Positive := 1; + TC_String2 : Wide_String (1..Second_String'Length); + TC_String3 : Wide_String (1..Third_String'Length); + Last : Natural := Natural'First; + + begin + + Ada.Wide_Text_IO.Open (Filter_File, -- Open. + Ada.Wide_Text_IO.In_File, + Filter_Filename); + + + -- Read the data of the First_String from the file, using the + -- Get procedure defined for Wide_Character data. + -- Verify that the character corresponds to the data originally + -- written to the file. + + while Pos <= First_String'Length loop + Ada.Wide_Text_IO.Get (Filter_File, Current_Char); -- Get. + if Current_Char /= First_String(Pos) then + Report.Failed + ("Incorrect Wide_Character read from file - 2"); + end if; + Pos := Pos + 1; + end loop; + + -- The first line of the file has been read, move to the second. + Ada.Wide_Text_IO.Skip_Line (Filter_File); -- Skip_Line. + + -- Read the Wide_String data from the second and third lines of + -- the file. + Ada.Wide_Text_IO.Get (Filter_File, TC_String2); -- Get. + Ada.Wide_Text_IO.Skip_Line (Filter_File); -- Skip_Line. + Ada.Wide_Text_IO.Get_Line (Filter_File, -- Get_Line. + TC_String3, Last); + + -- Verify data of second and third strings. + if TC_String2 /= Second_String then + Report.Failed ("Incorrect Wide_String read from file - 1"); + end if; + if TC_String3 /= Third_String then + Report.Failed ("Incorrect Wide_String read from file - 2"); + end if; + + -- The file should now be at EOF. + if not Ada.Wide_Text_IO.End_Of_File (Filter_File) then -- EOF. + Report.Failed ("File not empty following filtering"); + end if; + + exception + when others => + Report.Failed ("Exception in Filter_Block"); + raise; + end Filter_Block; + + exception + + when Incomplete => + raise; + when others => + Report.Failed ("Exception raised in Operational Test Block"); + + end Operational_Test_Block; + + Deletion: + begin + if Ada.Wide_Text_IO.Is_Open (Filter_File) then -- Is_Open. + Ada.Wide_Text_IO.Delete (Filter_File); -- Delete. + else + Ada.Wide_Text_IO.Open (Filter_File, -- Open. + Ada.Wide_Text_IO.Out_File, + Filter_Filename); + Ada.Wide_Text_IO.Delete (Filter_File); -- Delete. + end if; + exception + when others => + Report.Failed ("Delete not properly implemented for Wide_Text_IO"); + end Deletion; + + Report.Result; + +exception + when Incomplete => + Report.Result; + when others => + Report.Failed ( "Unexpected exception" ); + Report.Result; + +end CXAB001; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxac001.a b/gcc/testsuite/ada/acats/tests/cxa/cxac001.a new file mode 100644 index 000000000..a77d561f5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxac001.a @@ -0,0 +1,292 @@ +-- CXAC001.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 attribute T'Write will, for any specific non-limited +-- type T, write an item of the subtype to the stream. +-- +-- Check that the attribute T'Read will, for a specific non-limited +-- type T, read a value of the subtype from the stream. +-- +-- TEST DESCRIPTION: +-- The scenario depicted in this test is that of an environment where +-- product data is stored in stream form, then reconstructed into the +-- appropriate data structures. Several records of product information +-- are stored in an array; the array is passed as a parameter to a +-- procedure for storage in the stream. A header is created based on the +-- number of data records stored in the array. The header is then written +-- to the stream, followed by each record maintained in the array. +-- In order to retrieve data from the stream, the header information is +-- read from the stream, and the data stored in the header is used to +-- perform the appropriate number of read operations of record data from +-- the stream. All data read from the stream is validated against the +--- values that were written to the stream. +-- +-- APPLICABILITY CRITERIA: +-- Applicable to all systems capable of supporting IO operations on +-- external Stream_IO files. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 08 Nov 95 SAIC Corrected call to Read in Procedure Retrieve_Data +-- for ACVC 2.0.1. +-- 27 Feb 08 PWB.CTA Allowed for non-support of certain IO operations. +--! + +with Ada.Streams.Stream_IO; +with Report; + +procedure CXAC001 is + + package Strm_Pack renames Ada.Streams.Stream_IO; + The_File : Strm_Pack.File_Type; + The_Filename : constant String := + Report.Legal_File_Name ( Nam => "CXAC001" ); + Incomplete : exception; + + +begin + + Report.Test ("CXAC001", "Check that the 'Read and 'Write attributes " & + "will transfer an object of a specific, " & + "non-limited type to/from a stream"); + + Test_for_Stream_IO_Support: + begin + + -- If an implementation does not support Stream_IO in a particular + -- environment, the exception Use_Error or Name_Error will be raised on + -- calls to various Stream_IO operations. This block statement + -- encloses a call to Create, which should produce an exception in a + -- non-supportive environment. These exceptions will be handled to + -- produce a Not_Applicable result. + + Strm_Pack.Create (The_File, Strm_Pack.Out_File, The_Filename); + + exception + + when Ada.Streams.Stream_IO.Use_Error | + Ada.Streams.Stream_IO.Name_Error => + Report.Not_Applicable + ( "Files not supported - Create as Out_File for Stream_IO" ); + raise Incomplete; + + end Test_for_Stream_IO_Support; + + Operational_Test_Block: + declare + + The_Stream : Strm_Pack.Stream_Access; + Todays_Date : String (1 .. 6) := "271193"; + + type ID_Type is range 1 .. 100; + type Size_Type is (Small, Medium, Large, XLarge); + + type Header_Type is record + Number_of_Elements : Natural := 0; + Origination_Date : String (1 .. 6); + end record; + + type Data_Type is record + ID : ID_Type; + Size : Size_Type; + end record; + + type Data_Array_Type is array (Positive range <>) of Data_Type; + + Product_Information_1 : Data_Array_Type (1 .. 3) := ((20, Large), + (55, Small), + (89, XLarge)); + + Product_Information_2 : Data_Array_Type (1 .. 4) := (( 5, XLarge), + (27, Small), + (79, Medium), + (93, XLarge)); + + procedure Store_Data ( The_Stream : in Strm_Pack.Stream_Access; + The_Array : in Data_Array_Type ) is + Header : Header_Type; + begin + + -- Fill in header info. + Header.Number_of_Elements := The_Array'Length; + Header.Origination_Date := Todays_Date; + + -- Write header to stream. + Header_Type'Write (The_Stream, Header); + + -- Write each record in the array to the stream. + for I in 1 .. Header.Number_of_Elements loop + Data_Type'Write (The_Stream, The_Array (I)); + end loop; + + end Store_Data; + + procedure Retrieve_Data (The_Stream : in Strm_Pack.Stream_Access; + The_Header : out Header_Type; + The_Array : out Data_Array_Type ) is + begin + + -- Read header from the stream. + Header_Type'Read (The_Stream, The_Header); + + -- Read the records from the stream into the array. + for I in 1 .. The_Header.Number_of_Elements loop + Data_Type'Read (The_Stream, The_Array (I)); + end loop; + + end Retrieve_Data; + + begin + + -- Assign access value. + The_Stream := Strm_Pack.Stream (The_File); + + -- Product information is to be stored in the stream file. These + -- data arrays are of different sizes (actually, the records + -- are stored individually, not as a single array). Prior to the + -- record data being written, a header record is initialized with + -- information about the data to be written, then itself is written + -- to the stream. + + Store_Data (The_Stream, Product_Information_1); + Store_Data (The_Stream, Product_Information_2); + + Test_Verification_Block: + declare + Product_Header_1 : Header_Type; + Product_Header_2 : Header_Type; + Product_Array_1 : Data_Array_Type (1 .. 3); + Product_Array_2 : Data_Array_Type (1 .. 4); + begin + + Reset1: + begin + Strm_Pack.Reset (The_File, Strm_Pack.In_File); + exception + when Ada.Streams.Stream_IO.Use_Error => + Report.Not_Applicable + ( "Reset to In_File not supported for Stream_IO" ); + raise Incomplete; + end Reset1; + + -- Data is read from the stream, first the appropriate header, + -- then the associated data records, which are then reconstructed + -- into a data array of product information. + + Retrieve_Data (The_Stream, Product_Header_1, Product_Array_1); + + -- Validate a field in the header. + if (Product_Header_1.Origination_Date /= Todays_Date) or + (Product_Header_1.Number_of_Elements /= 3) + then + Report.Failed ("Incorrect Header_1 info read from stream"); + end if; + + -- Validate the data records read from the file. + for I in 1 .. Product_Header_1.Number_of_Elements loop + if (Product_Array_1(I) /= Product_Information_1(I)) then + Report.Failed ("Incorrect Product 1 info read from" & + " record: " & Integer'Image (I)); + end if; + end loop; + + -- Repeat this read and verify operation for the next parcel of + -- data. Again, header and data record information are read from + -- the same stream file. + Retrieve_Data (The_Stream, Product_Header_2, Product_Array_2); + + if (Product_Header_2.Origination_Date /= Todays_Date) or + (Product_Header_2.Number_of_Elements /= 4) + then + Report.Failed ("Incorrect Header_2 info read from stream"); + end if; + + for I in 1 .. Product_Header_2.Number_of_Elements loop + if (Product_Array_2(I) /= Product_Information_2(I)) then + Report.Failed ("Incorrect Product_2 info read from" & + " record: " & Integer'Image (I)); + end if; + end loop; + + exception + + when Incomplete => + raise; + + when Strm_Pack.End_Error => -- If correct number of + -- items not in file (data + -- overwritten), then fail. + Report.Failed ("Incorrect number of record elements in file"); + if not Strm_Pack.Is_Open (The_File) then + Strm_Pack.Open (The_File, Strm_Pack.Out_File, The_Filename); + end if; + + when others => + Report.Failed ("Exception raised in Data Verification Block"); + if not Strm_Pack.Is_Open (The_File) then + Strm_Pack.Open (The_File, Strm_Pack.Out_File, The_Filename); + end if; + + end Test_Verification_Block; + + exception + + when Incomplete => + raise; + + when others => + Report.Failed ("Exception raised in Operational Test Block"); + + end Operational_Test_Block; + + Deletion: + begin + -- Delete the file. + if Strm_Pack.Is_Open (The_File) then + Strm_Pack.Delete (The_File); + else + Strm_Pack.Open (The_File, Strm_Pack.Out_File, The_Filename); + Strm_Pack.Delete (The_File); + end if; + + exception + + when others => + Report.Failed + ( "Delete not properly implemented for Stream_IO" ); + end Deletion; + + Report.Result; + +exception + when Incomplete => + Report.Result; + when others => + Report.Failed ( "Unexpected exception" ); + Report.Result; + +end CXAC001; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxac002.a b/gcc/testsuite/ada/acats/tests/cxa/cxac002.a new file mode 100644 index 000000000..e4b303c4b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxac002.a @@ -0,0 +1,426 @@ +-- CXAC002.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 subprograms defined in package Ada.Streams.Stream_IO +-- are accessible, and that they provide the appropriate functionality. +-- +-- TEST DESCRIPTION: +-- This test simulates a user filter designed to capitalize the +-- characters of a string. It utilizes a variety of the subprograms +-- contained in the package Ada.Streams.Stream_IO. +-- Its purpose is to demonstrate the use of a variety of the capabilities +-- found in the Ada.Streams.Stream_IO package. +-- +-- APPLICABILITY CRITERIA: +-- This test is applicable to all implementations capable of supporting +-- external Stream_IO files. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 14 Nov 95 SAIC Corrected visibility problems; corrected +-- subtest validating result from function Name +-- for ACVC 2.0.1. +-- 05 Oct 96 SAIC Removed calls to Close/Open in test and replaced +-- them with a single call to Reset (per AI95-0001) +-- 26 Feb 97 PWB.CTA Allowed for non-support of some IO operations. +-- 09 Feb 01 RLB Corrected non-support check to avoid unintended +-- failures. +--! + +package CXAC002_0 is + + -- This function searches for the first instance of a specified substring + -- within a specified string, returning boolean result. (Case insensitive + -- analysis) + + function Find (Str : in String; Sub : in String) return Boolean; + +end CXAC002_0; + +package body CXAC002_0 is + + function Find (Str : in String; Sub : in String) return Boolean is + + New_Str : String(Str'First..Str'Last); + New_Sub : String(Sub'First..Sub'Last); + Pos : Integer := Str'First; -- Character index. + + function Upper_Case (Str : in String) return String is + subtype Upper is Character range 'A'..'Z'; + subtype Lower is Character range 'a'..'z'; + Ret : String(Str'First..Str'Last); + Pos : Integer; + begin + for I in Str'Range loop + if (Str(I) in Lower) then + Pos := Upper'Pos(Upper'First) + + (Lower'Pos(Str(I)) - Lower'Pos(Lower'First)); + Ret(I) := Upper'Val(Pos); + else + Ret(I) := Str (I); + end if; + end loop; + return Ret; + end Upper_Case; + + begin + + New_Str := Upper_Case(Str); -- Convert Str and Sub to upper + New_Sub := Upper_Case(Sub); -- case for comparison. + + while (Pos <= New_Str'Last-New_Sub'Length+1) -- Search until no more + and then -- sub-string-length + (New_Str(Pos..Pos+New_Sub'Length-1) /= New_Sub) -- slices remain. + loop + Pos := Pos + 1; + end loop; + + if (Pos > New_Str'Last-New_Sub'Length+1) then -- Substring not found. + return False; + else + return True; + end if; + + end Find; + +end CXAC002_0; + + +with Ada.Streams.Stream_IO, CXAC002_0, Report; +procedure CXAC002 is + Filter_File : Ada.Streams.Stream_IO.File_Type; + Filter_Stream : Ada.Streams.Stream_IO.Stream_Access; + Filter_Filename : constant String := + Report.Legal_File_Name ( Nam => "CXAC002" ); + Incomplete : Exception; + +begin + + Report.Test ("CXAC002", "Check that the subprograms defined in " & + "package Ada.Streams.Stream_IO are accessible, " & + "and that they provide the appropriate " & + "functionality"); + + Test_for_Stream_IO_Support: + + begin + + -- If an implementation does not support Stream_IO in a particular + -- environment, the exception Use_Error or Name_Error will be raised on + -- calls to various Stream_IO operations. This block statement + -- encloses a call to Create, which should produce an exception in a + -- non-supportive environment. These exceptions will be handled to + -- produce a Not_Applicable result. + + Ada.Streams.Stream_IO.Create (Filter_File, -- Create. + Ada.Streams.Stream_IO.Out_File, + Filter_Filename); + exception + + when Ada.Streams.Stream_IO.Use_Error | Ada.Streams.Stream_IO.Name_Error => + Report.Not_Applicable + ( "Files not supported - Create as Out_File for Stream_IO" ); + raise Incomplete; + + end Test_for_Stream_IO_Support; + + Operational_Test_Block: + declare + + use CXAC002_0; + use type Ada.Streams.Stream_IO.File_Mode; + use type Ada.Streams.Stream_IO.Count; + + File_Size : Ada.Streams.Stream_IO.Count := -- Count. + Ada.Streams.Stream_IO.Count'First; -- (0) + File_Index : Ada.Streams.Stream_IO.Positive_Count := -- Pos. Count. + Ada.Streams.Stream_IO.Positive_Count'First; -- (1) + + First_String : constant String := "this is going to be "; + Second_String : constant String := "the best year of your life"; + Total_Length : constant Natural := First_String'Length + + Second_String'Length; + Current_Char : Character := ' '; + + Cap_String : String (1..Total_Length) := (others => ' '); + + TC_Capital_String : constant String := + "THIS IS GOING TO BE THE BEST YEAR OF YOUR LIFE"; + + begin + + if not Ada.Streams.Stream_IO.Is_Open (Filter_File) then -- Is_Open + Report.Failed ("File not open following Create"); + end if; + + -- Call function Find to determine if the filename (Sub) is contained + -- in the result of Function Name. + + if not Find(Str => Ada.Streams.Stream_IO.Name(Filter_File), -- Name. + Sub => Filter_Filename) + then + Report.Failed ("Function Name provided incorrect filename"); + end if; + -- Stream. + Filter_Stream := Ada.Streams.Stream_IO.Stream (Filter_File); + + --- + + Enter_Data_In_Stream: + declare + Pos : Natural := 1; + Bad_Character_Found : Boolean := False; + begin + + -- Enter data from the first string into the stream. + while Pos <= Natural(First_String'Length) loop + -- Write all characters of the First_String to the stream. + Character'Write (Filter_Stream, First_String (Pos)); + Pos := Pos + 1; + -- Ensure data put in file on a regular basis. + if Pos mod 5 = 0 then + Ada.Streams.Stream_IO.Flush (Filter_File); -- Flush. + end if; + end loop; + + Ada.Streams.Stream_IO.Flush (Filter_File); -- Flush. + -- Reset to In_File mode and read stream contents. + Reset1: + begin + Ada.Streams.Stream_IO.Reset (Filter_File, -- Reset. + Ada.Streams.Stream_IO.In_File); + exception + when Ada.Streams.Stream_IO.Use_Error => + Report.Not_Applicable + ( "Reset to In_File not supported for Stream_IO" ); + raise Incomplete; + end Reset1; + + Pos := 1; + while Pos <= First_String'Length loop + -- Read one character from the stream. + Character'Read (Filter_Stream, Current_Char); -- 'Read + -- Verify character against the original string. + if Current_Char /= First_String(Pos) then + Bad_Character_Found := True; + end if; + Pos := Pos + 1; + end loop; + + if Bad_Character_Found then + Report.Failed ("Incorrect character read from stream"); + end if; + + -- Following user stream/string processing, the stream file is + -- appended to as follows: + + Reset2: + begin + Ada.Streams.Stream_IO.Reset (Filter_File, -- Reset. + Ada.Streams.Stream_IO.Append_File); + exception + when Ada.Streams.Stream_IO.Use_Error => + Report.Not_Applicable + ( "Reset to Append_File not supported for Stream_IO" ); + raise Incomplete; + end Reset2; + + if Ada.Streams.Stream_IO.Mode (Filter_File) /= -- Mode. + Ada.Streams.Stream_IO.Append_File + then + Report.Failed ("Incorrect mode following Reset to Append"); + end if; + + Pos := 1; + while Pos <= Natural(Second_String'Length) loop + -- Write all characters of the Second_String to the stream. + Character'Write (Filter_Stream, Second_String (Pos)); -- 'Write + Pos := Pos + 1; + end loop; + + Ada.Streams.Stream_IO.Flush (Filter_File); -- Flush. + + -- Record file statistics. + File_Size := Ada.Streams.Stream_IO.Size (Filter_File); -- Size. + + Index_Might_Not_Be_Supported: + begin + File_Index := Ada.Streams.Stream_IO.Index (Filter_File); -- Index. + exception + when Ada.Streams.Stream_IO.Use_Error => + Report.Not_Applicable ( "Index not supported for Stream_IO" ); + raise Incomplete; + end Index_Might_Not_Be_Supported; + + exception + when Incomplete => + raise; + when others => + Report.Failed ("Exception in Enter_Data_In_Stream block"); + raise; + end Enter_Data_In_Stream; + + --- + + Filter_Block: + declare + Pos : Positive := 1; + Full_String : constant String := First_String & Second_String; + + function Capitalize (Char : Character) return Character is + begin + if Char /= ' ' then + return Character'Val( Character'Pos(Char) - + (Character'Pos('a') - Character'Pos('A'))); + else + return Char; + end if; + end Capitalize; + + begin + + Reset3: + begin + Ada.Streams.Stream_IO.Reset (Filter_File, -- Reset. + Ada.Streams.Stream_IO.In_File); + exception + when Ada.Streams.Stream_IO.Use_Error => + Report.Not_Applicable + ( "Reset to In_File not supported for Stream_IO" ); + raise Incomplete; + end Reset3; + + if Ada.Streams.Stream_IO.Mode (Filter_File) /= -- Mode. + Ada.Streams.Stream_IO.In_File + then + Report.Failed ("Incorrect mode following Reset to In_File"); + end if; + + if not Ada.Streams.Stream_IO.Is_Open (Filter_File) then -- Is_Open + Report.Failed ( "Reset command did not leave file open" ); + end if; + + if Ada.Streams.Stream_IO.Size (Filter_File) /= -- Size. + File_Size + then + Report.Failed ("Reset file is not correct size"); + end if; + + if Ada.Streams.Stream_IO.Index (Filter_File) /= 1 then -- Index. + -- File position should have been reset to start of file. + Report.Failed ("Index of file not set to 1 following Reset"); + end if; + + while Pos <= Full_String'Length loop + -- Read one character from the stream. + Character'Read (Filter_Stream, Current_Char); -- 'Read + -- Verify character against the original string. + if Current_Char /= Full_String(Pos) then + Report.Failed ("Incorrect character read from stream"); + else + -- Capitalize the characters read from the stream, and + -- place them in a string variable. + Cap_String(Pos) := Capitalize (Current_Char); + end if; + Pos := Pos + 1; + end loop; + + -- File index should now be set to the position following the final + -- character in the file (the same as the index value stored at + -- the completion of the Enter_Data_In_Stream block). + if Ada.Streams.Stream_IO.Index (Filter_File) /= -- Index. + File_Index + then + Report.Failed ("Incorrect file index position"); + end if; + + -- The stream file should now be at EOF. -- EOF. + if not Ada.Streams.Stream_IO.End_Of_File (Filter_File) then + Report.Failed ("File not empty following filtering"); + end if; + + exception + + when Incomplete => + raise; + when others => + Report.Failed ("Exception in Filter_Block"); + raise; + end Filter_Block; + + --- + + Verification_Block: + begin + + -- Verify that the entire string was examined, and that the + -- process of capitalizing the character data was successful. + if Cap_String /= TC_Capital_String then + Report.Failed ("Incorrect Capitalization"); + end if; + + exception + when others => + Report.Failed ("Exception in Verification_Block"); + end Verification_Block; + + + exception + + when Incomplete => + raise; + when others => + Report.Failed ("Exception raised in Operational Test Block"); + + end Operational_Test_Block; + + Deletion: + begin + if Ada.Streams.Stream_IO.Is_Open (Filter_File) then -- Is_Open. + Ada.Streams.Stream_IO.Delete (Filter_File); -- Delete. + else + Ada.Streams.Stream_IO.Open (Filter_File, -- Open. + Ada.Streams.Stream_IO.Out_File, + Filter_Filename); + Ada.Streams.Stream_IO.Delete (Filter_File); -- Delete. + end if; + exception + when others => + Report.Failed + ( "Delete not properly implemented for Stream_IO" ); + end Deletion; + + Report.Result; + +exception + when Incomplete => + Report.Result; + when others => + Report.Failed ( "Unexpected exception" ); + Report.Result; + +end CXAC002; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxac003.a b/gcc/testsuite/ada/acats/tests/cxa/cxac003.a new file mode 100644 index 000000000..cc1e044d0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxac003.a @@ -0,0 +1,376 @@ +-- CXAC003.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 correct exceptions are raised when improperly +-- manipulating stream file objects. +-- +-- TEST DESCRIPTION: +-- This test is designed to focus on Stream_IO file manipulation +-- exceptions. Several potentially common user errors are examined in +-- the test: +-- +-- A Status_Error should be raised whenever an attempt is made to perform +-- an operation on a file that is closed. +-- +-- A Status_Error should be raised when an attempt is made to open a +-- stream file that is currently open. +-- +-- A Mode_Error should be raised when attempting to read from (use the +-- 'Read attribute) on an Out_File or Append_Mode file. +-- +-- A Mode_Error should be raised when checking for End Of File on a +-- file with mode Out_File or Append_Mode. +-- +-- A Mode_Error should be raised when attempting to write to (use the +-- 'Output attribute) on a file with mode In_File. +-- +-- A Name_Error should be raised when the string provided to the Name +-- parameter of an Open operation does not allow association of an +-- external file. +-- +-- APPLICABILITY CRITERIA: +-- This test is applicable to all implementations capable of supporting +-- external Stream_IO files. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 25 Feb 97 PWB.CTA Allowed for non-support of some IO operations +-- 02 Mar 01 PHL Check that Ada.Streams.Stream_IO.Stream raises +-- Status_Error if the file is not open. (DR 8652/ +-- 0056). +-- 15 Mar 01 RLB Readied for release. +--! + +with Ada.Streams.Stream_IO; +with Report; + +procedure CXAC003 is + + Stream_File_Object : Ada.Streams.Stream_IO.File_Type; + Stream_Access_Value : Ada.Streams.Stream_IO.Stream_Access; + Stream_Filename : constant String := + Report.Legal_File_Name ( Nam => "CXAC003" ); + Incomplete : exception; + +begin + + Report.Test ("CXAC003", "Check that the correct exceptions are " & + "raised when improperly manipulating stream " & + "file objects"); + + Test_for_Stream_IO_Support: + begin + -- If an implementation does not support Stream_IO in a particular + -- environment, the exception Use_Error or Name_Error will be raised on + -- calls to various Stream_IO operations. This block statement + -- encloses a call to Create, which should produce an exception in a + -- non-supportive environment. These exceptions will be handled to + -- produce a Not_Applicable result. + + Ada.Streams.Stream_IO.Create (Stream_File_Object, + Ada.Streams.Stream_IO.Out_File, + Stream_Filename); + + exception + + when Ada.Streams.Stream_IO.Use_Error | Ada.Streams.Stream_IO.Name_Error => + Report.Not_Applicable + ( "Files not supported - Create as Out_File for Stream_IO" ); + raise Incomplete; + + end Test_for_Stream_IO_Support; + + Operational_Test_Block: + begin + -- A potentially common error in a file processing environment + -- is to attempt to perform an operation on a stream file that is + -- not currently open. Status_Error should be raised in this case. + Check_Status_Error: + begin + Ada.Streams.Stream_IO.Close (Stream_File_Object); + -- Attempt to reset a file that is closed. + Ada.Streams.Stream_IO.Reset (Stream_File_Object, + Ada.Streams.Stream_IO.Out_File); + Report.Failed ("Exception not raised on Reset of closed file"); + exception + when Ada.Streams.Stream_IO.Status_Error => + null; + when others => + Report.Failed ("Incorrect exception raised - 1"); + end Check_Status_Error; + + -- A similar error is to use Ada.Streams.Stream_IO.Stream + -- to attempt to perform an operation on a stream file that is + -- not currently open. Status_Error should be raised in this case. + -- (Defect Report 8652/0046, as reflected in Technical Corrigendum 1.) + Check_Status_Error2: + begin + -- Ensure that the file is not open. + if Ada.Streams.Stream_Io.Is_Open (Stream_File_Object) then + Ada.Streams.Stream_Io.Close (Stream_File_Object); + end if; + Stream_Access_Value := + Ada.Streams.Stream_Io.Stream (Stream_File_Object); + Report.Failed ("Exception not raised on Stream of closed file"); + exception + when Ada.Streams.Stream_Io.Status_Error => + null; + when others => + Report.Failed ("Incorrect exception raised - 2"); + end Check_Status_Error2; + + -- Another potentially common error in a file processing environment + -- is to attempt to Open a stream file that is currently open. + -- Status_Error should be raised in this case. + Check_Status_Error3: + begin + -- Ensure that the file is open. + if not Ada.Streams.Stream_IO.Is_Open (Stream_File_Object) then + Ada.Streams.Stream_IO.Open (Stream_File_Object, + Ada.Streams.Stream_IO.In_File, + Stream_Filename); + end if; + Ada.Streams.Stream_IO.Open (Stream_File_Object, + Ada.Streams.Stream_IO.In_File, + Stream_Filename); + Report.Failed ("Exception not raised on Open of open file"); + exception + when Ada.Streams.Stream_IO.Status_Error => + null; + when others => + Report.Failed ("Incorrect exception raised - 3"); + end Check_Status_Error3; + + -- Another example of a potential error occurring in a file + -- processing environment is to attempt to use the 'Read attribute + -- on a stream file that is currently in Out_File or Append_File + -- mode. Mode_Error should be raised in both of these cases. + Check_Mode_Error: + declare + Int_Var : Integer := -10; + begin + + Reset1: + begin + Ada.Streams.Stream_IO.Reset (Stream_File_Object, + Ada.Streams.Stream_IO.Out_File); + exception + when Ada.Streams.Stream_IO.Use_Error => + Report.Not_Applicable + ( "Reset to Out_File not supported for Stream_IO - 1" ); + raise Incomplete; + end Reset1; + + Stream_Access_Value := + Ada.Streams.Stream_IO.Stream (Stream_File_Object); + Integer'Write (Stream_Access_Value, Int_Var); + + -- File contains an integer value, but is of mode Out_File. + Integer'Read (Stream_Access_Value, Int_Var); + Report.Failed ("Exception not raised by 'Read of Out_File"); + exception + when Incomplete => + raise; + when Ada.Streams.Stream_IO.Mode_Error => + null; + Try_Read: + begin + Reset2: + begin + Ada.Streams.Stream_IO.Reset + (Stream_File_Object, Ada.Streams.Stream_IO.Append_File); + exception + when Ada.Streams.Stream_IO.Use_Error => + Report.Not_Applicable + ( "Reset to Append_File not supported " & + "for Stream_IO - 2" ); + raise Incomplete; + end Reset2; + + Integer'Write (Stream_Access_Value, Int_Var); + -- Attempt read from Append_File mode file. + Integer'Read (Stream_Access_Value, Int_Var); + Report.Failed + ("Exception not raised by 'Read of Append file"); + exception + when Incomplete => + null; + when Ada.Streams.Stream_IO.Mode_Error => + null; + when others => + Report.Failed ("Incorrect exception raised - 4b"); + end Try_Read; + + when others => Report.Failed ("Incorrect exception raised - 4a"); + end Check_Mode_Error; + + -- Another example of a this type of potential error is to attempt + -- to check for End Of File on a stream file that is currently in + -- Out_File or Append_File mode. Mode_Error should also be raised + -- in both of these cases. + Check_End_File: + declare + Test_Boolean : Boolean := False; + begin + Reset3: + begin + Ada.Streams.Stream_IO.Reset (Stream_File_Object, + Ada.Streams.Stream_IO.Out_File); + exception + when Ada.Streams.Stream_IO.Use_Error => + Report.Not_Applicable + ( "Reset to Out_File not supported for Stream_IO - 3" ); + raise Incomplete; + end Reset3; + + Test_Boolean := + Ada.Streams.Stream_IO.End_Of_File (Stream_File_Object); + Report.Failed ("Exception not raised by EOF on Out_File"); + exception + when Incomplete => + null; + when Ada.Streams.Stream_IO.Mode_Error => + null; + EOF_For_Append_File: + begin + Reset4: + begin + Ada.Streams.Stream_IO.Reset + (Stream_File_Object, Ada.Streams.Stream_IO.Append_File); + exception + when Ada.Streams.Stream_IO.Use_Error => + Report.Not_Applicable + ( "Reset to Append_File not supported " & + "for Stream_IO - 4" ); + raise Incomplete; + end Reset4; + + Test_Boolean := + Ada.Streams.Stream_IO.End_Of_File (Stream_File_Object); + Report.Failed + ("Exception not raised by EOF of Append file"); + exception + when Incomplete => + raise; + when Ada.Streams.Stream_IO.Mode_Error => + null; + when others => + Report.Failed ("Incorrect exception raised - 5b"); + end EOF_For_Append_File; + + when others => Report.Failed ("Incorrect exception raised - 5a"); + end Check_End_File; + + + + -- In a similar situation to the above cases for attribute 'Read, + -- an attempt to use the 'Output attribute on a stream file that + -- is currently in In_File mode should result in Mode_Error being + -- raised. + Check_Output_Mode_Error: + begin + Reset5: + begin + Ada.Streams.Stream_IO.Reset (Stream_File_Object, + Ada.Streams.Stream_IO.In_File); + exception + when Ada.Streams.Stream_IO.Use_Error => + Report.Not_Applicable + ( "Reset to In_File not supported for Stream_IO - 6" ); + raise Incomplete; + end Reset5; + + Stream_Access_Value := + Ada.Streams.Stream_IO.Stream (Stream_File_Object); + String'Output (Stream_Access_Value, "User-Oriented String"); + Report.Failed ("Exception not raised by 'Output to In_File"); + exception + when Incomplete => + null; + when Ada.Streams.Stream_IO.Mode_Error => + null; + when others => + Report.Failed ("Incorrect exception raised - 6"); + end Check_Output_Mode_Error; + + -- Any case of attempting to Open a stream file with a string for + -- the parameter Name that does not allow the identification of an + -- external file will result in the exception Name_Error being + -- raised. + Check_Illegal_File_Name: + begin + if Ada.Streams.Stream_IO.Is_Open (Stream_File_Object) then + Ada.Streams.Stream_IO.Close (Stream_File_Object); + end if; + -- No external file exists with this filename, allowing no + -- association with an internal file object, resulting in the + -- raising of the exception Name_Error. + Ada.Streams.Stream_IO.Open(File => Stream_File_Object, + Mode => Ada.Streams.Stream_IO.Out_File, + Name => Report.Legal_File_Name(2)); + Report.Failed ("Exception not raised by bad filename on Open"); + exception + when Ada.Streams.Stream_IO.Name_Error => + null; + when others => + Report.Failed ("Incorrect exception raised - 7"); + end Check_Illegal_File_Name; + + exception + when Incomplete => + null; + when others => + Report.Failed ("Unexpected exception in Operational Test Block"); + + end Operational_Test_Block; + + Deletion: + begin + if Ada.Streams.Stream_IO.Is_Open (Stream_File_Object) then + Ada.Streams.Stream_IO.Delete (Stream_File_Object); + else + Ada.Streams.Stream_IO.Open (Stream_File_Object, + Ada.Streams.Stream_IO.Out_File, + Stream_Filename); + Ada.Streams.Stream_IO.Delete (Stream_File_Object); + end if; + exception + when others => + Report.Failed + ( "Delete not properly implemented for Stream_IO" ); + end Deletion; + + Report.Result; + +exception + when Incomplete => + Report.Result; + when others => + Report.Failed ( "Unexpected exception" ); + Report.Result; + +end CXAC003; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxac004.a b/gcc/testsuite/ada/acats/tests/cxa/cxac004.a new file mode 100644 index 000000000..9cc88b93c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxac004.a @@ -0,0 +1,310 @@ +-- CXAC004.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 Stream_Access type and Stream function found in package +-- Ada.Text_IO.Text_Streams allows a text file to be processed with the +-- functionality of streams. +-- +-- TEST DESCRIPTION: +-- This test verifies that the package Ada.Text_IO.Text_Streams is +-- available and that the functionality it contains allows a text file to +-- be manipulated as a stream. +-- The test defines data objects of a variety of types that can be stored +-- in a text file. A text file and associated text stream are then +-- defined, and the 'Write attribute is used to enter the individual data +-- items into the text stream. Once all the individual data items have +-- been written to the stream, the 'Output attribute is used to write +-- arrays of these same data objects to the stream. +-- The text file is reset to serve as an input file, and the 'Read +-- attribute is used to extract the individual data items from the +-- stream. These items are then verified against the data originally +-- written to the stream. Finally, the 'Input attribute is used to +-- extract the data arrays from the stream. These arrays are then +-- verified against the original data written to the stream. +-- +-- APPLICABILITY CRITERIA: +-- Applicable to implementations that support external text files. +-- +-- CHANGE HISTORY: +-- 06 Jul 95 SAIC Initial prerelease version. +-- 26 Feb 97 PWB.CTA Allowed for non-support of some IO operations; +-- removed requirement for support of decimal types. +--! + +with Report; +with Ada.Text_IO; +with Ada.Text_IO.Text_Streams; +with Ada.Characters.Latin_1; +with Ada.Strings.Unbounded; + +procedure CXAC004 is + + Data_File : Ada.Text_IO.File_Type; + Data_Filename : constant String := + Report.Legal_File_Name ( Nam => "CXAC004" ); + Incomplete : exception; + +begin + + Report.Test ("CXAC004", "Check that the Stream_Access type and Stream " & + "function found in package " & + "Ada.Text_IO.Text_Streams allows a text file to " & + "be processed with the functionality of streams"); + + Test_for_IO_Support: + begin + + -- Check for Text_IO support in creating the data file. If the + -- implementation does not support external files, Name_Error or + -- Use_Error will be raised at the point of the following call to + -- Create, resulting in a Not_Applicable test result. + + Ada.Text_IO.Create(Data_File, Ada.Text_IO.Out_File, Data_Filename); + + exception + + when Ada.Text_IO.Use_Error | Ada.Text_IO.Name_Error => + Report.Not_Applicable + ( "Files not supported - Create as Out_File for Text_IO" ); + raise Incomplete; + + end Test_for_IO_Support; + + Test_Block: + declare + use Ada.Characters.Latin_1, Ada.Strings.Unbounded; + TC_Items : constant := 3; + + -- Declare types and objects that will be used as data values to be + -- written to and read from the text file/stream. + + type Enum_Type is (Red, Yellow, Green, Blue, Indigo); + type Fixed_Type is delta 0.125 range 0.0..255.0; + type Float_Type is digits 7 range 0.0..1.0E5; + type Modular_Type is mod 256; + subtype Str_Type is String(1..4); + + type Char_Array_Type is array (1..TC_Items) of Character; + type Enum_Array_Type is array (1..TC_Items) of Enum_Type; + type Fixed_Array_Type is array (1..TC_Items) of Fixed_Type; + type Float_Array_Type is array (1..TC_Items) of Float_Type; + type Int_Array_Type is array (1..TC_Items) of Integer; + type Mod_Array_Type is array (1..TC_Items) of Modular_Type; + type Str_Array_Type is array (1..TC_Items) of Str_Type; + type Unb_Str_Array_Type is array (1..TC_Items) of Unbounded_String; + + Char_Array : Char_Array_Type := ('A', 'z', Yen_Sign); + TC_Char_Array_1, + TC_Char_Array_2 : Char_Array_Type := (others => Space); + + Enum_Array : Enum_Array_Type := (Blue, Yellow, Indigo); + TC_Enum_Array_1, + TC_Enum_Array_2 : Enum_Array_Type := (others => Red); + + Fix_Array : Fixed_Array_Type := (0.125, 123.5, 250.750); + TC_Fix_Array_1, + TC_Fix_Array_2 : Fixed_Array_Type := (others => 0.0); + + Flt_Array : Float_Array_Type := (1.0, 150.0, 1500.0); + TC_Flt_Array_1, + TC_Flt_Array_2 : Float_Array_Type := (others => 0.0); + + Int_Array : Int_Array_Type := (124, 2349, -24_001); + TC_Int_Array_1, + TC_Int_Array_2 : Int_Array_Type := (others => -99); + + Mod_Array : Mod_Array_Type := (10, 127, 255); + TC_Mod_Array_1, + TC_Mod_Array_2 : Mod_Array_Type := (others => 0); + + Str_Array : Str_Array_Type := ("abcd", "klmn", "wxyz"); + TC_Str_Array_1, + TC_Str_Array_2 : Str_Array_Type := (others => " "); + + UStr_Array : Unb_Str_Array_Type := + (To_Unbounded_String("cat"), + To_Unbounded_String("testing"), + To_Unbounded_String("ACVC")); + TC_UStr_Array_1, + TC_UStr_Array_2 : Unb_Str_Array_Type := + (others => Null_Unbounded_String); + + -- Create a stream access object pointing to the data file. + + Data_Stream : Ada.Text_IO.Text_Streams.Stream_Access := + Ada.Text_IO.Text_Streams.Stream(File => Data_File); + + begin + + -- Use the 'Write attribute to enter the three sets of data items + -- into the data stream. + -- Note that the data will be mixed within the text file. + + for i in 1..TC_Items loop + Character'Write (Data_Stream, Char_Array(i)); + Enum_Type'Write (Data_Stream, Enum_Array(i)); + Fixed_Type'Write (Data_Stream, Fix_Array(i)); + Float_Type'Write (Data_Stream, Flt_Array(i)); + Integer'Write (Data_Stream, Int_Array(i)); + Modular_Type'Write (Data_Stream, Mod_Array(i)); + Str_Type'Write (Data_Stream, Str_Array(i)); + Unbounded_String'Write(Data_Stream, UStr_Array(i)); + end loop; + + -- Use the 'Output attribute to enter the entire arrays of each + -- type of data items into the data stream. + -- Note that the array bounds will be written to the stream as part + -- of the action of the 'Output attribute. + + Char_Array_Type'Output (Data_Stream, Char_Array); + Enum_Array_Type'Output (Data_Stream, Enum_Array); + Fixed_Array_Type'Output (Data_Stream, Fix_Array); + Float_Array_Type'Output (Data_Stream, Flt_Array); + Int_Array_Type'Output (Data_Stream, Int_Array); + Mod_Array_Type'Output (Data_Stream, Mod_Array); + Str_Array_Type'Output (Data_Stream, Str_Array); + Unb_Str_Array_Type'Output (Data_Stream, UStr_Array); + + -- Reset the data file to mode In_File. The data file will now serve + -- as the source of data which will be compared to the original data + -- written to the file above. + Reset1: + begin + Ada.Text_IO.Reset (File => Data_File, Mode => Ada.Text_IO.In_File); + exception + when Ada.Text_IO.Use_Error => + Report.Not_Applicable + ( "Reset to In_File not supported for Text_IO" ); + raise Incomplete; + end Reset1; + + -- Extract and validate all the single data items from the stream. + + for i in 1..TC_Items loop + Character'Read (Data_Stream, TC_Char_Array_1(i)); + Enum_Type'Read (Data_Stream, TC_Enum_Array_1(i)); + Fixed_Type'Read (Data_Stream, TC_Fix_Array_1(i)); + Float_Type'Read (Data_Stream, TC_Flt_Array_1(i)); + Integer'Read (Data_Stream, TC_Int_Array_1(i)); + Modular_Type'Read (Data_Stream, TC_Mod_Array_1(i)); + Str_Type'Read (Data_Stream, TC_Str_Array_1(i)); + Unbounded_String'Read (Data_Stream, TC_UStr_Array_1(i)); + end loop; + + if TC_Char_Array_1 /= Char_Array then + Report.Failed("Character values do not match"); + end if; + if TC_Enum_Array_1 /= Enum_Array then + Report.Failed("Enumeration values do not match"); + end if; + if TC_Fix_Array_1 /= Fix_Array then + Report.Failed("Fixed point values do not match"); + end if; + if TC_Flt_Array_1 /= Flt_Array then + Report.Failed("Floating point values do not match"); + end if; + if TC_Int_Array_1 /= Int_Array then + Report.Failed("Integer values do not match"); + end if; + if TC_Mod_Array_1 /= Mod_Array then + Report.Failed("Modular values do not match"); + end if; + if TC_Str_Array_1 /= Str_Array then + Report.Failed("String values do not match"); + end if; + if TC_UStr_Array_1 /= UStr_Array then + Report.Failed("Unbounded_String values do not match"); + end if; + + -- Extract and validate all data arrays from the data stream. + -- Note that the 'Input attribute denotes a function, whereas the + -- other stream oriented attributes in this test denote procedures. + + TC_Char_Array_2 := Char_Array_Type'Input(Data_Stream); + TC_Enum_Array_2 := Enum_Array_Type'Input(Data_Stream); + TC_Fix_Array_2 := Fixed_Array_Type'Input(Data_Stream); + TC_Flt_Array_2 := Float_Array_Type'Input(Data_Stream); + TC_Int_Array_2 := Int_Array_Type'Input(Data_Stream); + TC_Mod_Array_2 := Mod_Array_Type'Input(Data_Stream); + TC_Str_Array_2 := Str_Array_Type'Input(Data_Stream); + TC_UStr_Array_2 := Unb_Str_Array_Type'Input(Data_Stream); + + if TC_Char_Array_2 /= Char_Array then + Report.Failed("Character array values do not match"); + end if; + if TC_Enum_Array_2 /= Enum_Array then + Report.Failed("Enumeration array values do not match"); + end if; + if TC_Fix_Array_2 /= Fix_Array then + Report.Failed("Fixed point array values do not match"); + end if; + if TC_Flt_Array_2 /= Flt_Array then + Report.Failed("Floating point array values do not match"); + end if; + if TC_Int_Array_2 /= Int_Array then + Report.Failed("Integer array values do not match"); + end if; + if TC_Mod_Array_2 /= Mod_Array then + Report.Failed("Modular array values do not match"); + end if; + if TC_Str_Array_2 /= Str_Array then + Report.Failed("String array values do not match"); + end if; + if TC_UStr_Array_2 /= UStr_Array then + Report.Failed("Unbounded_String array values do not match"); + end if; + + exception + when Incomplete => + raise; + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Deletion: + begin + -- Delete the data file. + if not Ada.Text_IO.Is_Open(Data_File) then + Ada.Text_IO.Open(Data_File, Ada.Text_IO.In_File, Data_Filename); + end if; + Ada.Text_IO.Delete(Data_File); + + exception + when others => + Report.Failed + ( "Delete not properly implemented for Text_IO" ); + + end Deletion; + + Report.Result; + +exception + when Incomplete => + Report.Result; + when others => + Report.Failed ( "Unexpected exception" ); + Report.Result; + +end CXAC004; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxac005.a b/gcc/testsuite/ada/acats/tests/cxa/cxac005.a new file mode 100644 index 000000000..34a971f7a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxac005.a @@ -0,0 +1,343 @@ +-- CXAC005.A +-- +-- Grant of Unlimited Rights +-- +-- The Ada Conformity Assessment Authority (ACAA) holds unlimited +-- rights in the software and documentation contained herein. Unlimited +-- rights are the same as those granted by the U.S. Government for older +-- parts of the Ada Conformity Assessment Test Suite, and are defined +-- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA +-- intends to confer upon all recipients unlimited rights equal to those +-- held by the ACAA. 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 stream file positioning work as specified. (Defect Report +-- 8652/0055). +-- +-- CHANGE HISTORY: +-- 12 FEB 2001 PHL Initial version. +-- 14 MAR 2001 RLB Readied for release; fixed Not_Applicable check +-- to terminate test gracefully. +-- +--! +with Ada.Streams.Stream_Io; +use Ada.Streams; +with Ada.Exceptions; +use Ada.Exceptions; +with Report; +use Report; +procedure CXAC005 is + + Incomplete : exception; + + procedure TC_Assert (Condition : Boolean; Message : String) is + begin + if not Condition then + Failed (Message); + end if; + end TC_Assert; + + package Checked_Stream_Io is + + type File_Type (Max_Size : Stream_Element_Count) is limited private; + function Stream_Io_File (File : File_Type) return Stream_Io.File_Type; + + procedure Create (File : in out File_Type; + Mode : in Stream_Io.File_Mode := Stream_Io.Out_File; + Name : in String := ""; + Form : in String := ""); + + procedure Open (File : in out File_Type; + Mode : in Stream_Io.File_Mode; + Name : in String; + Form : in String := ""); + + procedure Close (File : in out File_Type); + procedure Delete (File : in out File_Type); + + procedure Reset (File : in out File_Type; + Mode : in Stream_Io.File_Mode); + procedure Reset (File : in out File_Type); + + procedure Read (File : in out File_Type; + Item : out Stream_Element_Array; + Last : out Stream_Element_Offset; + From : in Stream_Io.Positive_Count); + + procedure Read (File : in out File_Type; + Item : out Stream_Element_Array; + Last : out Stream_Element_Offset); + + procedure Write (File : in out File_Type; + Item : in Stream_Element_Array; + To : in Stream_Io.Positive_Count); + + procedure Write (File : in out File_Type; + Item : in Stream_Element_Array); + + procedure Set_Index (File : in out File_Type; + To : in Stream_Io.Positive_Count); + + function Index (File : in File_Type) return Stream_Io.Positive_Count; + + procedure Set_Mode (File : in out File_Type; + Mode : in Stream_Io.File_Mode); + + private + type File_Type (Max_Size : Stream_Element_Count) is + record + File : Stream_Io.File_Type; + Index : Stream_Io.Positive_Count; + Contents : + Stream_Element_Array + (Stream_Element_Offset (Ident_Int (1)) .. Max_Size); + end record; + end Checked_Stream_Io; + + package body Checked_Stream_Io is + + use Stream_Io; + + function Stream_Io_File (File : File_Type) return Stream_Io.File_Type is + begin + return File.File; + end Stream_Io_File; + + procedure Create (File : in out File_Type; + Mode : in Stream_Io.File_Mode := Stream_Io.Out_File; + Name : in String := ""; + Form : in String := "") is + begin + Stream_Io.Create (File.File, Mode, Name, Form); + File.Index := Stream_Io.Index (File.File); + if Mode = Append_File then + TC_Assert (File.Index = Stream_Io.Size (File.File) + 1, + "Index /= Size + 1 -- Create - Append_File"); + else + TC_Assert (File.Index = 1, "Index /= 1 -- Create - " & + File_Mode'Image (Mode)); + end if; + end Create; + + procedure Open (File : in out File_Type; + Mode : in Stream_Io.File_Mode; + Name : in String; + Form : in String := "") is + begin + Stream_Io.Open (File.File, Mode, Name, Form); + File.Index := Stream_Io.Index (File.File); + if Mode = Append_File then + TC_Assert (File.Index = Stream_Io.Size (File.File) + 1, + "Index /= Size + 1 -- Open - Append_File"); + else + TC_Assert (File.Index = 1, "Index /= 1 -- Open - " & + File_Mode'Image (Mode)); + end if; + end Open; + + procedure Close (File : in out File_Type) is + begin + Stream_Io.Close (File.File); + end Close; + + procedure Delete (File : in out File_Type) is + begin + Stream_Io.Delete (File.File); + end Delete; + + procedure Reset (File : in out File_Type; + Mode : in Stream_Io.File_Mode) is + begin + Stream_Io.Reset (File.File, Mode); + File.Index := Stream_Io.Index (File.File); + if Mode = Append_File then + TC_Assert (File.Index = Stream_Io.Size (File.File) + 1, + "Index /= Size + 1 -- Reset - Append_File"); + else + TC_Assert (File.Index = 1, "Index /= 1 -- Reset - " & + File_Mode'Image (Mode)); + end if; + end Reset; + + procedure Reset (File : in out File_Type) is + begin + Reset (File, Stream_Io.Mode (File.File)); + end Reset; + + + procedure Read (File : in out File_Type; + Item : out Stream_Element_Array; + Last : out Stream_Element_Offset; + From : in Stream_Io.Positive_Count) is + begin + Set_Index (File, From); + Read (File, Item, Last); + end Read; + + procedure Read (File : in out File_Type; + Item : out Stream_Element_Array; + Last : out Stream_Element_Offset) is + Index : constant Stream_Element_Offset := + Stream_Element_Offset (File.Index); + begin + Stream_Io.Read (File.File, Item, Last); + if Last < Item'Last then + TC_Assert (Item (Item'First .. Last) = + File.Contents (Index .. Index + Last - Item'First), + "Incorrect data read from file - 1"); + TC_Assert (Count (Index + Last - Item'First) = + Stream_Io.Size (File.File), + "Read stopped before end of file"); + File.Index := Count (Index + Last - Item'First) + 1; + else + TC_Assert (Item = File.Contents (Index .. Index + Item'Length - 1), + "Incorrect data read from file - 2"); + File.Index := File.Index + Item'Length; + end if; + end Read; + + procedure Write (File : in out File_Type; + Item : in Stream_Element_Array; + To : in Stream_Io.Positive_Count) is + begin + Set_Index (File, To); + Write (File, Item); + end Write; + + procedure Write (File : in out File_Type; + Item : in Stream_Element_Array) is + Index : constant Stream_Element_Offset := + Stream_Element_Offset (File.Index); + begin + Stream_Io.Write (File.File, Item); + File.Contents (Index .. Index + Item'Length - 1) := Item; + File.Index := File.Index + Item'Length; + TC_Assert (File.Index = Stream_Io.Index (File.File), + "Write failed to move the index"); + end Write; + + procedure Set_Index (File : in out File_Type; + To : in Stream_Io.Positive_Count) is + begin + Stream_Io.Set_Index (File.File, To); + File.Index := Stream_Io.Index (File.File); + TC_Assert (File.Index = To, "Set_Index failed"); + end Set_Index; + + function Index (File : in File_Type) return Stream_Io.Positive_Count is + New_Index : constant Count := Stream_Io.Index (File.File); + begin + TC_Assert (New_Index = File.Index, "Index changed unexpectedly"); + return New_Index; + end Index; + + procedure Set_Mode (File : in out File_Type; + Mode : in Stream_Io.File_Mode) is + Old_Index : constant Count := File.Index; + begin + Stream_Io.Set_Mode (File.File, Mode); + File.Index := Stream_Io.Index (File.File); + if Mode = Append_File then + TC_Assert (File.Index = Stream_Io.Size (File.File) + 1, + "Index /= Size + 1 -- Set_Mode - Append_File"); + else + TC_Assert (File.Index = Old_Index, "Set_Mode changed the index"); + end if; + end Set_Mode; + + end Checked_Stream_Io; + + package Csio renames Checked_Stream_Io; + + F : Csio.File_Type (100); + S : Stream_Element_Array (1 .. 10); + Last : Stream_Element_Offset; + +begin + + Test ("CXAC005", "Check that stream file positioning work as specified"); + + declare + Name : constant String := Legal_File_Name; + begin + begin + Csio.Create (F, Name => Name); + exception + when others => + Not_Applicable ("Files not supported - Creation with Out_File for Stream_IO"); + raise Incomplete; + end; + + for I in Stream_Element range 1 .. 10 loop + Csio.Write (F, ((1 => I + 2))); + end loop; + Csio.Write (F, (1 .. 15 => 11)); + Csio.Write (F, (1 .. 15 => 12), To => 15); + + Csio.Reset (F); + + for I in Stream_Element range 1 .. 10 loop + Csio.Write (F, (1 => I)); + end loop; + Csio.Write (F, (1 .. 15 => 13)); + Csio.Write (F, (1 .. 15 => 14), To => 15); + Csio.Write (F, (1 => 90)); + + Csio.Set_Mode (F, Stream_Io.In_File); + + Csio.Read (F, S, Last); + Csio.Read (F, S, Last, From => 3); + Csio.Read (F, S, Last, From => 28); + + Csio.Set_Mode (F, Stream_Io.Append_File); + Csio.Write (F, (1 .. 5 => 88)); + + Csio.Close (F); + + Csio.Open (F, Name => Name, Mode => Stream_Io.Append_File); + Csio.Write (F, (1 .. 3 => 33)); + + Csio.Set_Mode (F, Stream_Io.In_File); + Csio.Read (F, S, Last, From => 20); + Csio.Read (F, S, Last); + Csio.Reset (F, Stream_Io.Out_File); + + Csio.Write (F, (1 .. 9 => 99)); + + -- Check the contents of the entire file. + declare + S : Stream_Element_Array + (1 .. Stream_Element_Offset + (Stream_Io.Size (Csio.Stream_Io_File (F)))); + begin + Csio.Reset (F, Stream_Io.In_File); + Csio.Read (F, S, Last); + end; + + Csio.Delete (F); + end; + + Result; +exception + when Incomplete => + Report.Result; + when E:others => + Report.Failed ("Unexpected exception raised - " & Exception_Name (E) & + " - " & Exception_Message (E)); + Report.Result; + +end CXAC005; + diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaca01.a b/gcc/testsuite/ada/acats/tests/cxa/cxaca01.a new file mode 100644 index 000000000..cda8776a5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxaca01.a @@ -0,0 +1,291 @@ +-- CXACA01.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 default attributes 'Write and 'Read work properly when +-- used with objects of a variety of types, including records with +-- default discriminants, records without default discriminants, but +-- which have the discriminant described in a representation clause for +-- the type, and arrays. +-- +-- TEST DESCRIPTION: +-- This test simulates a basic sales record system, using Stream_IO to +-- allow the storage of heterogeneous data in a single stream file. +-- +-- Four types of data are written to the stream file for each product. +-- First, the "header" information on the product is written. +-- This is an object of a discriminated (with default) record +-- type. This is followed by an integer object containing a count of +-- the number of sales data records to follow. The corresponding number +-- of sales records follow in the stream. These are of a record type +-- with a discriminant without a default, but where the discriminant is +-- included in the representation clause for the type. Finally, an +-- array object with statistical sales information for the product is +-- written to the stream. +-- +-- Objects of both record types specified below (discriminated records +-- with defaults, and discriminated records w/o defaults that have the +-- discriminant included in a representation clause for the type) should +-- have their discriminants included in the stream when using 'Write. +-- Likewise, discriminants should be extracted from the stream when +-- using 'Read. +-- +-- APPLICABILITY CRITERIA: +-- Applicable to all implementations that support external +-- Stream_IO files. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +with FXACA00; +with Ada.Streams.Stream_IO; +with Report; + +procedure CXACA01 is + +begin + + Report.Test ("CXACA01", "Check that 'Write and 'Read work properly " & + "when used with complex data types"); + + Test_for_Stream_IO_Support: + declare + + Info_File : Ada.Streams.Stream_IO.File_Type; + Info_Stream : Ada.Streams.Stream_IO.Stream_Access; + The_Filename : constant String := Report.Legal_File_Name; + + begin + + -- If an implementation does not support Stream_IO in a particular + -- environment, the exception Use_Error or Name_Error will be raised on + -- calls to various Stream_IO operations. This block statement + -- encloses a call to Create, which should produce an exception in a + -- non-supportive environment. These exceptions will be handled to + -- produce a Not_Applicable result. + + Ada.Streams.Stream_IO.Create (Info_File, + Ada.Streams.Stream_IO.Out_File, + The_Filename); + + Operational_Test_Block: + declare + + begin + + Info_Stream := Ada.Streams.Stream_IO.Stream (Info_File); + + -- Write all of the product information (record, integer, and array + -- objects) defined in package FXACA00 into the stream. + + Store_Data_Block: + begin + + -- Write information about first product to the stream. + FXACA00.Product_Type'Write (Info_Stream, FXACA00.Product_01); + Integer'Write (Info_Stream, FXACA00.Sale_Count_01); + FXACA00.Sales_Record_Type'Write(Info_Stream, FXACA00.Sale_Rec_01); + FXACA00.Sales_Record_Type'Write(Info_Stream, FXACA00.Sale_Rec_02); + FXACA00.Sales_Statistics_Type'Write + (Info_Stream, FXACA00.Product_01_Stats); + + -- Write information about second product to the stream. + -- Note: No Sales_Record_Type objects. + FXACA00.Product_Type'Write (Info_Stream, FXACA00.Product_02); + Integer'Write (Info_Stream, FXACA00.Sale_Count_02); + FXACA00.Sales_Statistics_Type'Write + (Info_Stream, FXACA00.Product_02_Stats); + + -- Write information about third product to the stream. + FXACA00.Product_Type'Write (Info_Stream, FXACA00.Product_03); + Integer'Write (Info_Stream, FXACA00.Sale_Count_03); + FXACA00.Sales_Record_Type'Write(Info_Stream, FXACA00.Sale_Rec_03); + FXACA00.Sales_Record_Type'Write(Info_Stream, FXACA00.Sale_Rec_04); + FXACA00.Sales_Record_Type'Write(Info_Stream, FXACA00.Sale_Rec_05); + FXACA00.Sales_Statistics_Type'Write + (Info_Stream, FXACA00.Product_03_Stats); + + end Store_Data_Block; + + + Verify_Data_Block: + declare + + use FXACA00; -- Used within this block only. + + type Domestic_Rec_Array_Type is + array (Positive range <>) of Sales_Record_Type (Domestic); + + type Foreign_Rec_Array_Type is + array (Positive range <>) of Sales_Record_Type (Foreign); + + TC_Rec1 : Domestic_Rec_Array_Type (1..2); + TC_Rec3 : Foreign_Rec_Array_Type (1..3); + + TC_Product1 : Product_Type; + TC_Product2, + TC_Product3 : Product_Type (Foreign); + + TC_Count1, + TC_Count2, + TC_Count3 : Integer := -10; -- Initialized to dummy value. + + TC_Stat1, + TC_Stat2, + TC_Stat3 : Sales_Statistics_Type := (others => 500); + + begin + + Ada.Streams.Stream_IO.Reset (Info_File, + Ada.Streams.Stream_IO.In_File); + + -- Read all of the data that is contained in the stream. + -- Compare all data with the original data in package FXACA00 + -- that was written to the stream. + -- The calls to the read attribute are in anticipated order, based + -- on the order of data written to the stream. Possible errors, + -- such as data placement, overwriting, etc., will be manifest as + -- exceptions raised by the attribute during an unsuccessful read + -- attempt. + + -- Extract data on first product. + Product_Type'Read (Info_Stream, TC_Product1); + Integer'Read (Info_Stream, TC_Count1); + + -- Two "domestic" variant sales records will be read from the + -- stream. + for i in 1 .. TC_Count1 loop + Sales_Record_Type'Read (Info_Stream, TC_Rec1(i) ); + end loop; + + Sales_Statistics_Type'Read (Info_Stream, TC_Stat1); + + + -- Extract data on second product. + Product_Type'Read (Info_Stream, TC_Product2); + Integer'Read (Info_Stream, TC_Count2); + Sales_Statistics_Type'Read (Info_Stream, TC_Stat2); + + + -- Extract data on third product. + Product_Type'Read (Info_Stream, TC_Product3); + Integer'Read (Info_Stream, TC_Count3); + + -- Three "foreign" variant sales records will be read from the + -- stream. + for i in 1 .. TC_Count3 loop + Sales_Record_Type'Read (Info_Stream, TC_Rec3(i) ); + end loop; + + Sales_Statistics_Type'Read (Info_Stream, TC_Stat3); + + + -- After all the data has been correctly extracted, the file + -- should be empty. + + if not Ada.Streams.Stream_IO.End_Of_File (Info_File) then + Report.Failed ("Stream file not empty"); + end if; + + -- Verify that the data values read from the stream are the same + -- as those written to the stream. + + -- Verify the information of the first product. + if ((Product_01 /= TC_Product1) or else + (Product_01.Manufacture /= TC_Product1.Manufacture) or else + (Sale_Count_01 /= TC_Count1) or else + (Sale_Rec_01 /= TC_Rec1(1)) or else + (Sale_Rec_01.Buyer /= TC_Rec1(1).Buyer) or else + (Sale_Rec_02 /= TC_Rec1(2)) or else + (Sale_Rec_02.Buyer /= TC_Rec1(2).Buyer) or else + (Product_01_Stats /= TC_Stat1)) + then + Report.Failed ("Product 1 information incorrect"); + end if; + + -- Verify the information of the second product. + if not ((Product_02 = TC_Product2) and then + (Sale_Count_02 = TC_Count2) and then + (Product_02_Stats = TC_Stat2)) + then + Report.Failed ("Product 2 information incorrect"); + end if; + + -- Verify the information of the third product. + if ((Product_03 /= TC_Product3) or else + (Product_03.Manufacture /= TC_Product3.Manufacture) or else + (Sale_Count_03 /= TC_Count3) or else + (Sale_Rec_03 /= TC_Rec3(1)) or else + (Sale_Rec_03.Buyer /= TC_Rec3(1).Buyer) or else + (Sale_Rec_04 /= TC_Rec3(2)) or else + (Sale_Rec_04.Buyer /= TC_Rec3(2).Buyer) or else + (Sale_Rec_05 /= TC_Rec3(3)) or else + (Sale_Rec_05.Buyer /= TC_Rec3(3).Buyer) or else + (Product_03_Stats /= TC_Stat3)) + then + Report.Failed ("Product 3 information incorrect"); + end if; + + end Verify_Data_Block; + + exception + + when others => + Report.Failed ("Exception raised in Operational Test Block"); + + end Operational_Test_Block; + + if Ada.Streams.Stream_IO.Is_Open (Info_File) then + Ada.Streams.Stream_IO.Delete (Info_File); + else + Ada.Streams.Stream_IO.Open (Info_File, + Ada.Streams.Stream_IO.In_File, + The_Filename); + Ada.Streams.Stream_IO.Delete (Info_File); + end if; + + exception + + -- Since Use_Error or Name_Error can be raised if, for the specified + -- mode, the environment does not support Stream_IO operations, + -- the following handlers are included: + + when Ada.Streams.Stream_IO.Name_Error => + Report.Not_Applicable ("Name_Error raised on Stream IO Create"); + + when Ada.Streams.Stream_IO.Use_Error => + Report.Not_Applicable ("Use_Error raised on Stream IO Create"); + + when others => + Report.Failed ("Unexpected exception raised on Stream IO Create"); + + end Test_for_Stream_IO_Support; + + Report.Result; + +end CXACA01; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaca02.a b/gcc/testsuite/ada/acats/tests/cxa/cxaca02.a new file mode 100644 index 000000000..5106dd399 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxaca02.a @@ -0,0 +1,360 @@ +-- CXACA02.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 user defined subprograms can override the default +-- attributes 'Read and 'Write using attribute definition clauses. +-- Use objects of record types. +-- +-- TEST DESCRIPTION: +-- This test demonstrates that the default implementations of the +-- 'Read and 'Write attributes can be overridden by user specified +-- subprograms in conjunction with attribute definition clauses. +-- These attributes have been overridden below, and in the user defined +-- substitutes, values are added or subtracted to global variables. +-- The global variables are evaluated to ensure that the user defined +-- subprograms were used in overriding the type-related default +-- attributes. +-- +-- APPLICABILITY CRITERIA: +-- Applicable to all implementations that support external +-- Stream_IO files. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 21 Nov 95 SAIC Corrected recursive attribute definitions +-- for ACVC 2.0.1. +-- 24 Aug 96 SAIC Corrected typo in test verification criteria. +-- +--! + +with Report; +with Ada.Streams.Stream_IO; + +procedure CXACA02 is +begin + + Report.Test ("CXACA02", "Check that user defined subprograms can " & + "override the default attributes 'Read and " & + "'Write using attribute definition clauses"); + + Test_for_Stream_IO_Support: + declare + + Data_File : Ada.Streams.Stream_IO.File_Type; + Data_Stream : Ada.Streams.Stream_IO.Stream_Access; + The_Filename : constant String := Report.Legal_File_Name; + + begin + + -- If an implementation does not support Stream_IO in a particular + -- environment, the exception Use_Error or Name_Error will be raised on + -- calls to various Stream_IO operations. This block statement + -- encloses a call to Create, which should produce an exception in a + -- non-supportive environment. These exceptions will be handled to + -- produce a Not_Applicable result. + + Ada.Streams.Stream_IO.Create (Data_File, + Ada.Streams.Stream_IO.Out_File, + The_Filename); + + Operational_Test_Block: + declare + + type Origin_Type is (Foreign, Domestic); + subtype String_Data_Type is String(1..8); + + type Product_Type is + record + Item : String_Data_Type; + ID : Natural range 1..100; + Manufacture : Origin_Type := Domestic; + Distributor : String_Data_Type; + Importer : String_Data_Type; + end record; + + type Sales_Record_Type is + record + Name : String_Data_Type; + Sale_Item : Boolean := False; + Buyer : Origin_Type; + Quantity_Discount : Boolean; + Cash_Discount : Boolean; + end record; + + + -- Mode conformant, user defined subprograms that will override + -- the type-related attributes. + -- In this test, the user defines these subprograms to add/subtract + -- specific values from global variables. + + procedure Product_Read + ( Stream : access Ada.Streams.Root_Stream_Type'Class; + The_Item : out Product_Type ); + + procedure Product_Write + ( Stream : access Ada.Streams.Root_Stream_Type'Class; + The_Item : Product_Type ); + + procedure Sales_Read + ( Stream : access Ada.Streams.Root_Stream_Type'Class; + The_Item : out Sales_Record_Type ); + + procedure Sales_Write + ( Stream : access Ada.Streams.Root_Stream_Type'Class; + The_Item : Sales_Record_Type ); + + -- Attribute definition clauses. + + for Product_Type'Read use Product_Read; + for Product_Type'Write use Product_Write; + + for Sales_Record_Type'Read use Sales_Read; + for Sales_Record_Type'Write use Sales_Write; + + + -- Object Declarations + + Product_01 : Product_Type := + ("Product1", 1, Domestic, "Distrib1", "Import 1"); + Product_02 : Product_Type := + ("Product2", 2, Foreign, "Distrib2", "Import 2"); + + Sale_Rec_01 : Sales_Record_Type := + ("Buyer 01", False, Domestic, True, True); + Sale_Rec_02 : Sales_Record_Type := + ("Buyer 02", True, Domestic, True, False); + Sale_Rec_03 : Sales_Record_Type := (Name => "Buyer 03", + Sale_Item => True, + Buyer => Foreign, + Quantity_Discount => False, + Cash_Discount => True); + Sale_Rec_04 : Sales_Record_Type := + ("Buyer 04", True, Foreign, False, False); + Sale_Rec_05 : Sales_Record_Type := + ("Buyer 05", False, Foreign, False, False); + + TC_Read_Total : Integer := 100; + TC_Write_Total : Integer := 0; + + + -- Subprogram bodies. + -- These subprograms are designed to override the default attributes + -- 'Read and 'Write for the specified types. Each adds/subtracts + -- a quantity to/from a program control variable, indicating its + -- activity. In addition, each component of the record is + -- individually read from or written to the stream, using the + -- appropriate 'Read or 'Write attribute for the component type. + -- The string components are moved to/from the stream using the + -- 'Input and 'Output attributes for the string subtype, so that + -- the bounds of the strings are also written/read. + + procedure Product_Read + ( Stream : access Ada.Streams.Root_Stream_Type'Class; + The_Item : out Product_Type ) is + begin + TC_Read_Total := TC_Read_Total - 10; + + The_Item.Item := String_Data_Type'Input(Data_Stream); -- Field 1. + Natural'Read(Data_Stream, The_Item.ID); -- Field 2. + Origin_Type'Read(Data_Stream, -- Field 3. + The_Item.Manufacture); + The_Item.Distributor := -- Field 4. + String_Data_Type'Input(Data_Stream); + The_Item.Importer := -- Field 5. + String_Data_Type'Input(Data_Stream); + end Product_Read; + + + procedure Product_Write + ( Stream : access Ada.Streams.Root_Stream_Type'Class; + The_Item : Product_Type ) is + begin + TC_Write_Total := TC_Write_Total + 5; + + String_Data_Type'Output(Data_Stream, The_Item.Item); -- Field 1. + Natural'Write(Data_Stream, The_Item.ID); -- Field 2. + Origin_Type'Write(Data_Stream, -- Field 3. + The_Item.Manufacture); + String_Data_Type'Output(Data_Stream, -- Field 4. + The_Item.Distributor); + String_Data_Type'Output(Data_Stream, -- Field 5. + The_Item.Importer); + end Product_Write; + + + procedure Sales_Read + ( Stream : access Ada.Streams.Root_Stream_Type'Class; + The_Item : out Sales_Record_Type ) is + begin + TC_Read_Total := TC_Read_Total - 20; + + The_Item.Name := String_Data_Type'Input(Data_Stream); -- Field 1. + Boolean'Read(Data_Stream, The_Item.Sale_Item); -- Field 2. + Origin_Type'Read(Data_Stream, The_Item.Buyer); -- Field 3. + Boolean'Read(Data_Stream, The_Item.Quantity_Discount); -- Field 4. + Boolean'Read(Data_Stream, The_Item.Cash_Discount); -- Field 5. + end Sales_Read; + + + procedure Sales_Write + ( Stream : access Ada.Streams.Root_Stream_Type'Class; + The_Item : Sales_Record_Type ) is + begin + TC_Write_Total := TC_Write_Total + 10; + + String_Data_Type'Output(Data_Stream, The_Item.Name); -- Field 1. + Boolean'Write(Data_Stream, The_Item.Sale_Item); -- Field 2. + Origin_Type'Write(Data_Stream, The_Item.Buyer); -- Field 3. + Boolean'Write(Data_Stream, The_Item.Quantity_Discount); -- Field 4. + Boolean'Write(Data_Stream, The_Item.Cash_Discount); -- Field 5. + end Sales_Write; + + + + begin + + Data_Stream := Ada.Streams.Stream_IO.Stream (Data_File); + + -- Write product and sales data to the stream. + + Product_Type'Write (Data_Stream, Product_01); + Sales_Record_Type'Write (Data_Stream, Sale_Rec_01); + Sales_Record_Type'Write (Data_Stream, Sale_Rec_02); + + Product_Type'Write (Data_Stream, Product_02); + Sales_Record_Type'Write (Data_Stream, Sale_Rec_03); + Sales_Record_Type'Write (Data_Stream, Sale_Rec_04); + Sales_Record_Type'Write (Data_Stream, Sale_Rec_05); + + -- Read data from the stream, and verify the use of the user specified + -- attributes. + + Verify_Data_Block: + declare + + TC_Product1, + TC_Product2 : Product_Type; + + TC_Sale1, + TC_Sale2, + TC_Sale3, + TC_Sale4, + TC_Sale5 : Sales_Record_Type; + + begin + + -- Reset the mode of the stream file so that Read/Input + -- operations may be performed. + + Ada.Streams.Stream_IO.Reset (Data_File, + Ada.Streams.Stream_IO.In_File); + + -- Data is read/reconstructed from the stream, in the order that + -- the data was placed into the stream. + + Product_Type'Read (Data_Stream, TC_Product1); + Sales_Record_Type'Read (Data_Stream, TC_Sale1); + Sales_Record_Type'Read (Data_Stream, TC_Sale2); + + Product_Type'Read (Data_Stream, TC_Product2); + Sales_Record_Type'Read (Data_Stream, TC_Sale3); + Sales_Record_Type'Read (Data_Stream, TC_Sale4); + Sales_Record_Type'Read (Data_Stream, TC_Sale5); + + -- Verify product data was correctly written to/read from stream. + + if TC_Product1 /= Product_01 then + Report.Failed ("Data verification error, Product 1"); + end if; + if TC_Product2 /= Product_02 then + Report.Failed ("Data verification error, Product 2"); + end if; + + if TC_Sale1 /= Sale_Rec_01 then + Report.Failed ("Data verification error, Sale_Rec_01"); + end if; + if TC_Sale2 /= Sale_Rec_02 then + Report.Failed ("Data verification error, Sale_Rec_02"); + end if; + if TC_Sale3 /= Sale_Rec_03 then + Report.Failed ("Data verification error, Sale_Rec_03"); + end if; + if TC_Sale4 /= Sale_Rec_04 then + Report.Failed ("Data verification error, Sale_Rec_04"); + end if; + if TC_Sale5 /= Sale_Rec_05 then + Report.Failed ("Data verification error, Sale_Rec_05"); + end if; + + -- Verify that the user defined subprograms were used to + -- override the default 'Read and 'Write attributes. + -- There were two "product" reads and two writes; there + -- were five "sale record" reads and five writes. + + if (TC_Read_Total /= -20) or (TC_Write_Total /= 60) then + Report.Failed ("Incorrect use of user defined attributes"); + end if; + + end Verify_Data_Block; + + exception + + when others => + Report.Failed ("Exception raised in Operational Test Block"); + + end Operational_Test_Block; + + if Ada.Streams.Stream_IO.Is_Open (Data_File) then + Ada.Streams.Stream_IO.Delete (Data_File); + else + Ada.Streams.Stream_IO.Open (Data_File, + Ada.Streams.Stream_IO.Out_File, + The_Filename); + Ada.Streams.Stream_IO.Delete (Data_File); + end if; + + + exception + + -- Since Use_Error or Name_Error can be raised if, for the specified + -- mode, the environment does not support Stream_IO operations, + -- the following handlers are included: + + when Ada.Streams.Stream_IO.Name_Error => + Report.Not_Applicable ("Name_Error raised on Stream IO Create"); + + when Ada.Streams.Stream_IO.Use_Error => + Report.Not_Applicable ("Use_Error raised on Stream IO Create"); + + when others => + Report.Failed ("Unexpected exception raised"); + + end Test_for_Stream_IO_Support; + + Report.Result; + +end CXACA02; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxacb01.a b/gcc/testsuite/ada/acats/tests/cxa/cxacb01.a new file mode 100644 index 000000000..ac4a905e8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxacb01.a @@ -0,0 +1,264 @@ +-- CXACB01.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 default attributes 'Input and 'Output work properly when +-- used with objects of a variety of types, including two-dimensional +-- arrays and records without default discriminants. +-- +-- TEST DESCRIPTION: +-- This test simulates utility company service record storage, using +-- Stream_IO to allow the storage of heterogeneous data in a single +-- stream file. +-- +-- Three types of data are written to the stream file for each utility +-- service customer. +-- First, the general information on the customer is written. +-- This is an object of a discriminated (without default) record +-- type. This is followed by an integer object containing a count of +-- the number of service months for the customer. Finally, a +-- two-dimensional array object with monthly consumption information for +-- the customer is written to the stream. +-- +-- Objects of record types with discriminants without defaults should +-- have their discriminants included in the stream when using 'Output. +-- Likewise, discriminants should be extracted +-- from the stream when using 'Input. Similarly, array bounds are written +-- to and read from the stream when using 'Output and 'Input with array +-- objects. +-- +-- APPLICABILITY CRITERIA: +-- Applicable to all implementations that support external +-- Stream_IO files. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +with FXACB00; +with Ada.Streams.Stream_IO; +with Report; + +procedure CXACB01 is +begin + + Report.Test ("CXACB01", "Check that the default attributes 'Input and " & + "'Output work properly when used with objects " & + "of record, natural, and array types" ); + + Test_for_Stream_IO_Support: + declare + + Util_File : Ada.Streams.Stream_IO.File_Type; + Util_Stream : Ada.Streams.Stream_IO.Stream_Access; + Utility_Service_Filename : constant String := Report.Legal_File_Name; + + begin + + -- If an implementation does not support Stream_IO in a particular + -- environment, the exception Use_Error or Name_Error will be raised on + -- calls to various Stream_IO operations. This block statement + -- encloses a call to Create, which should produce an exception in a + -- non-supportive environment. These exceptions will be handled to + -- produce a Not_Applicable result. + + Ada.Streams.Stream_IO.Create (Util_File, + Ada.Streams.Stream_IO.Out_File, + Utility_Service_Filename); + + Operational_Test_Block: + declare + + -- The following procedure will store all of the customer specific + -- information into the stream. + + procedure Store_Data_In_Stream + (Customer : in FXACB00.Service_Type; + Months : in FXACB00.Months_In_Service_Type; + History : in FXACB00.Service_History_Type) is + begin + FXACB00.Service_Type'Output (Util_Stream, Customer); + FXACB00.Months_In_Service_Type'Output (Util_Stream, Months); + FXACB00.Service_History_Type'Output (Util_Stream, History); + end Store_Data_In_Stream; + + + -- The following procedure will remove from the stream all of the + -- customer related information. + + procedure Retrieve_Data_From_Stream + (Customer : out FXACB00.Service_Type; + Months : out FXACB00.Months_In_Service_Type; + History : out FXACB00.Service_History_Type) is + begin + Customer := FXACB00.Service_Type'Input (Util_Stream); + Months := FXACB00.Months_In_Service_Type'Input (Util_Stream); + History := FXACB00.Service_History_Type'Input (Util_Stream); + end Retrieve_Data_From_Stream; + + + begin + + Util_Stream := Ada.Streams.Stream_IO.Stream (Util_File); + + -- Write all of the customer service information (record, numeric, + -- and array objects) defined in package FXACB00 into the stream. + + Data_Storage_Block: + begin + + Store_Data_In_Stream (Customer => FXACB00.Customer1, + Months => FXACB00.C1_Months, + History => FXACB00.C1_Service_History); + + Store_Data_In_Stream (FXACB00.Customer2, + FXACB00.C2_Months, + History => FXACB00.C2_Service_History); + + Store_Data_In_Stream (Months => FXACB00.C3_Months, + History => FXACB00.C3_Service_History, + Customer => FXACB00.Customer3); + end Data_Storage_Block; + + + Data_Verification_Block: + declare + + TC_Residence : FXACB00.Service_Type (FXACB00.Residence); + TC_Apartment : FXACB00.Service_Type (FXACB00.Apartment); + TC_Commercial : FXACB00.Service_Type (FXACB00.Commercial); + + + TC_Months1, + TC_Months2, + TC_Months3 : FXACB00.Months_In_Service_Type := + FXACB00.Months_In_Service_Type'First; + + + TC_History1 : + FXACB00.Service_History_Type (FXACB00.Quarterly_Period_Type, + FXACB00.Month_In_Quarter_Type) := + (others => (others => FXACB00.Electric_Usage_Type'Last)); + + TC_History2 : + FXACB00.Service_History_Type + (FXACB00.Quarterly_Period_Type range + FXACB00.Spring .. FXACB00.Summer, + FXACB00.Month_In_Quarter_Type) := + (others => (others => FXACB00.Electric_Usage_Type'Last)); + + TC_History3 : + FXACB00.Service_History_Type (FXACB00.Quarterly_Period_Type, + FXACB00.Month_In_Quarter_Type) := + (others => (others => FXACB00.Electric_Usage_Type'Last)); + + begin + + Ada.Streams.Stream_IO.Reset (Util_File, + Ada.Streams.Stream_IO.In_File); + + -- Input all of the data that is contained in the stream. + -- Compare all data with the original data in package FXACB00 + -- that was written to the stream. + + Retrieve_Data_From_Stream (TC_Residence, TC_Months1, TC_History1); + Retrieve_Data_From_Stream (TC_Apartment, TC_Months2, TC_History2); + Retrieve_Data_From_Stream (Customer => TC_Commercial, + Months => TC_Months3, + History => TC_History3); + + -- After all the data has been correctly extracted, the file + -- should be empty. + + if not Ada.Streams.Stream_IO.End_Of_File (Util_File) then + Report.Failed ("Stream file not empty"); + end if; + + -- Verify that the data values read from the stream are the same + -- as those written to the stream. + + if ((FXACB00."/="(FXACB00.Customer1, TC_Residence)) or else + (FXACB00."/="(FXACB00.Customer2, TC_Apartment)) or else + (FXACB00."/="(FXACB00.Customer3, TC_Commercial))) + then + Report.Failed ("Customer information incorrect"); + end if; + + if ((FXACB00."/="(FXACB00.C1_Months, TC_Months1)) or + (FXACB00."/="(FXACB00.C2_Months, TC_Months2)) or + (FXACB00."/="(FXACB00.C3_Months, TC_Months3))) + then + Report.Failed ("Number of Months information incorrect"); + end if; + + if not ((FXACB00."="(FXACB00.C1_Service_History, TC_History1)) and + (FXACB00."="(FXACB00.C2_Service_History, TC_History2)) and + (FXACB00."="(FXACB00.C3_Service_History, TC_History3))) + then + Report.Failed ("Service history information incorrect"); + end if; + + end Data_Verification_Block; + + exception + + when others => + Report.Failed ("Exception raised in Operational Test Block"); + + end Operational_Test_Block; + + -- Delete the file. + if Ada.Streams.Stream_IO.Is_Open (Util_File) then + Ada.Streams.Stream_IO.Delete (Util_File); + else + Ada.Streams.Stream_IO.Open (Util_File, + Ada.Streams.Stream_IO.Out_File, + Utility_Service_Filename); + Ada.Streams.Stream_IO.Delete (Util_File); + end if; + + + exception + + -- Since Use_Error or Name_Error can be raised if, for the specified + -- mode, the environment does not support Stream_IO operations, + -- the following handlers are included: + + when Ada.Streams.Stream_IO.Name_Error => + Report.Not_Applicable ("Name_Error raised on Stream IO Create"); + + when Ada.Streams.Stream_IO.Use_Error => + Report.Not_Applicable ("Use_Error raised on Stream IO Create"); + + when others => + Report.Failed ("Unexpected exception raised"); + + end Test_for_Stream_IO_Support; + + Report.Result; + +end CXACB01; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxacb02.a b/gcc/testsuite/ada/acats/tests/cxa/cxacb02.a new file mode 100644 index 000000000..a0ade9ebe --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxacb02.a @@ -0,0 +1,421 @@ +-- CXACB02.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 user defined subprograms can override the default +-- attributes 'Input and 'Output using attribute definition clauses, +-- when used with objects of discriminated record and multi-dimensional +-- array types. +-- +-- TEST DESCRIPTION: +-- This test demonstrates that the default implementations of the +-- 'Input and 'Output attributes can be overridden by user specified +-- subprograms in conjunction with attribute definition clauses. +-- These attributes have been overridden below, and in the user defined +-- substitutes, values are added or subtracted to global variables. +-- Following the completion of the writing/reading test, the global +-- variables are evaluated to ensure that the user defined subprograms +-- were used in overriding the type-related default attributes. +-- +-- APPLICABILITY CRITERIA: +-- Applicable to all implementations that support external +-- Stream_IO files. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 14 Nov 95 SAIC Corrected test errors for ACVC 2.0.1. +-- +--! + +with Report; +with Ada.Streams.Stream_IO; + +procedure CXACB02 is +begin + + Report.Test ("CXACB02", "Check that user defined subprograms can " & + "override the default attributes 'Input and " & + "'Output using attribute definition clauses"); + + Test_for_Stream_IO_Support: + declare + + Util_File : Ada.Streams.Stream_IO.File_Type; + Util_Stream : Ada.Streams.Stream_IO.Stream_Access; + Utility_Filename : constant String := Report.Legal_File_Name; + + begin + + -- If an implementation does not support Stream_IO in a particular + -- environment, the exception Use_Error or Name_Error will be raised on + -- calls to various Stream_IO operations. This block statement + -- encloses a call to Create, which should produce an exception in a + -- non-supportive environment. These exceptions will be handled to + -- produce a Not_Applicable result. + + Ada.Streams.Stream_IO.Create (Util_File, + Ada.Streams.Stream_IO.Out_File, + Utility_Filename); + + Operational_Test_Block: + declare + + type Customer_Type is (Residence, Apartment, Commercial); + type Electric_Usage_Type is range 0..100000; + type Months_In_Service_Type is range 1..12; + type Quarterly_Period_Type is (Spring, Summer, Autumn, Winter); + subtype Month_In_Quarter_Type is Positive range 1..3; + type Service_History_Type is + array (Quarterly_Period_Type range <>, + Month_In_Quarter_Type range <>) of Electric_Usage_Type; + + type Service_Type (Customer : Customer_Type) is + record + Name : String (1..21); + Account_ID : Natural range 0..100; + case Customer is + when Residence | Apartment => + Low_Income_Credit : Boolean := False; + when Commercial => + Baseline_Allowance : Natural range 0..1000; + Quantity_Discount : Boolean := False; + end case; + end record; + + + -- Mode conformant, user defined subprograms that will override + -- the type-related attributes. + -- In this test, the user defines these subprograms to add/subtract + -- specific values from global variables. + + function Service_Input + (Stream : access Ada.Streams.Root_Stream_Type'Class) + return Service_Type; + + procedure Service_Output + (Stream : access Ada.Streams.Root_Stream_Type'Class; + Item : Service_Type); + + function History_Input + (Stream : access Ada.Streams.Root_Stream_Type'Class) + return Service_History_Type; + + procedure History_Output + (Stream : access Ada.Streams.Root_Stream_Type'Class; + Item : Service_History_Type); + + + -- Attribute definition clauses. + + for Service_Type'Input use Service_Input; + for Service_Type'Output use Service_Output; + + for Service_History_Type'Input use History_Input; + for Service_History_Type'Output use History_Output; + + + -- Object Declarations + + Customer1 : Service_Type (Residence) := + (Residence, "1221 Morningstar Lane", 44, False); + Customer2 : Service_Type (Apartment) := + (Customer => Apartment, + Account_ID => 67, + Name => "15 South Front St. #8", + Low_Income_Credit => True); + Customer3 : Service_Type (Commercial) := + (Commercial, + "12442 Central Avenue ", + 100, + Baseline_Allowance => 938, + Quantity_Discount => True); + + C1_Service_History : + Service_History_Type (Quarterly_Period_Type, + Month_In_Quarter_Type) := + (Spring => (1 => 35, 2 => 39, 3 => 32), + Summer => (1 => 34, 2 => 33, 3 => 39), + Autumn => (1 => 45, 2 => 40, 3 => 38), + Winter => (1 => 53, 2 => 0, 3 => 0)); + + C2_Service_History : + Service_History_Type (Quarterly_Period_Type range Spring..Summer, + Month_In_Quarter_Type) := + (Spring => (23, 22, 0), Summer => (0, 0, 0)); + + C3_Service_History : + Service_History_Type (Quarterly_Period_Type, + Month_In_Quarter_Type) := + (others => (others => 200)); + + + TC_Input_Total : Integer := 0; + TC_Output_Total : Integer := 0; + + + -- Subprogram bodies. + -- These subprograms are designed to override the default attributes + -- 'Input and 'Output for the specified types. Each adds/subtracts + -- a quantity to/from a program control variable, indicating its + -- activity. Each user defined "Input" function uses the 'Read + -- attribute for the type to accomplish the operation. Likewise, + -- each user defined "Output" subprogram uses the 'Write attribute + -- for the type. + + function Service_Input + ( Stream : access Ada.Streams.Root_Stream_Type'Class ) + return Service_Type is + Customer : Customer_Type; + begin + TC_Input_Total := TC_Input_Total + 1; + + -- Extract the discriminant value from the stream. + -- This discriminant would not otherwise be extracted from the + -- stream when the Service_Type'Read attribute is used below. + Customer_Type'Read (Stream, Customer); + + declare + -- Declare a constant of Service_Type, using the value just + -- read from the stream as the discriminant value of the + -- object. + Service : Service_Type(Customer); + begin + Service_Type'Read (Stream, Service); + return Service; + end; + end Service_Input; + + + procedure Service_Output + ( Stream : access Ada.Streams.Root_Stream_Type'Class; + Item : Service_Type ) is + begin + TC_Output_Total := TC_Output_Total + 2; + -- Write the discriminant value to the stream. + -- The attribute 'Write (for the record type) will not write the + -- discriminant of the record object to the stream. Therefore, it + -- must be explicitly written using the 'Write attribute of the + -- discriminant type. + Customer_Type'Write (Stream, Item.Customer); + -- Write the record component values (but not the discriminant) to + -- the stream. + Service_Type'Write (Stream, Item); + end Service_Output; + + + function History_Input + ( Stream : access Ada.Streams.Root_Stream_Type'Class ) + return Service_History_Type is + Quarter_Bound_Low : Quarterly_Period_Type; + Quarter_Bound_High : Quarterly_Period_Type; + Month_Bound_Low : Month_In_Quarter_Type; + Month_Bound_High : Month_In_Quarter_Type; + begin + TC_Input_Total := TC_Input_Total + 3; + + -- Read the value of the array bounds from the stream. + -- Use these bounds in the creation of an array object that will + -- be used to store data from the stream. + -- The array bound values would not otherwise be read from the + -- stream by use of the Service_History_Type'Read attribute. + Quarterly_Period_Type'Read (Stream, Quarter_Bound_Low); + Quarterly_Period_Type'Read (Stream, Quarter_Bound_High); + Month_In_Quarter_Type'Read (Stream, Month_Bound_Low); + Month_In_Quarter_Type'Read (Stream, Month_Bound_High); + + declare + Service_History_Array : + Service_History_Type + (Quarterly_Period_Type range + Quarter_Bound_Low..Quarter_Bound_High, + Month_In_Quarter_Type range + Month_Bound_Low .. Month_Bound_High); + begin + Service_History_Type'Read (Stream, Service_History_Array); + return Service_History_Array; + end; + end History_Input; + + + procedure History_Output + ( Stream : access Ada.Streams.Root_Stream_Type'Class; + Item : Service_History_Type ) is + begin + TC_Output_Total := TC_Output_Total + 7; + -- Write the upper/lower bounds of the array object dimensions to + -- the stream. + Quarterly_Period_Type'Write (Stream, Item'First(1)); + Quarterly_Period_Type'Write (Stream, Item'Last(1)); + Month_In_Quarter_Type'Write (Stream, Item'First(2)); + Month_In_Quarter_Type'Write (Stream, Item'Last(2)); + -- Write the array values to the stream in canonical order (last + -- dimension varying fastest). + Service_History_Type'Write (Stream, Item); + end History_Output; + + + + begin + + Util_Stream := Ada.Streams.Stream_IO.Stream (Util_File); + + -- Write data to the stream. A customer service record is followed + -- by a service history array. + + Service_Type'Output (Util_Stream, Customer1); + Service_History_Type'Output (Util_Stream, C1_Service_History); + + Service_Type'Output (Util_Stream, Customer2); + Service_History_Type'Output (Util_Stream, C2_Service_History); + + Service_Type'Output (Util_Stream, Customer3); + Service_History_Type'Output (Util_Stream, C3_Service_History); + + + -- Read data from the stream, and verify the use of the user specified + -- attributes. + + Verify_Data_Block: + declare + + TC_Residence : Service_Type (Residence); + TC_Apartment : Service_Type (Apartment); + TC_Commercial : Service_Type (Commercial); + + TC_History1 : Service_History_Type (Quarterly_Period_Type, + Month_In_Quarter_Type) := + (others => (others => Electric_Usage_Type'First)); + + TC_History2 : Service_History_Type (Quarterly_Period_Type + range Spring .. Summer, + Month_In_Quarter_Type) := + (others => (others => Electric_Usage_Type'First)); + + TC_History3 : Service_History_Type (Quarterly_Period_Type, + Month_In_Quarter_Type) := + (others => (others => Electric_Usage_Type'First)); + + begin + + -- Reset Stream file to mode In_File. + + Ada.Streams.Stream_IO.Reset (Util_File, + Ada.Streams.Stream_IO.In_File); + + -- Read data from the stream. + + TC_Residence := Service_Type'Input (Util_Stream); + TC_History1 := Service_History_Type'Input (Util_Stream); + + TC_Apartment := Service_Type'Input (Util_Stream); + TC_History2 := Service_History_Type'Input (Util_Stream); + + TC_Commercial := Service_Type'Input (Util_Stream); + TC_History3 := Service_History_Type'Input (Util_Stream); + + + -- Verify product data was correctly written to/read from stream, + -- including discriminants and array bounds. + + if (TC_Residence /= Customer1) or + (TC_Residence.Customer /= Customer1.Customer) or + (TC_History1'Last(1) /= C1_Service_History'Last(1)) or + (TC_History1'First(1) /= C1_Service_History'First(1)) or + (TC_History1'Last(2) /= C1_Service_History'Last(2)) or + (TC_History1'First(2) /= C1_Service_History'First(2)) + then + Report.Failed ("Incorrect data from stream - 1"); + end if; + + if (TC_Apartment /= Customer2) or + (TC_Apartment.Customer /= Customer2.Customer) or + (TC_History2 /= C2_Service_History) or + (TC_History2'Last(1) /= C2_Service_History'Last(1)) or + (TC_History2'First(1) /= C2_Service_History'First(1)) or + (TC_History2'Last(2) /= C2_Service_History'Last(2)) or + (TC_History2'First(2) /= C2_Service_History'First(2)) + then + Report.Failed ("Incorrect data from stream - 2"); + end if; + + if (TC_Commercial /= Customer3) or + (TC_Commercial.Customer /= Customer3.Customer) or + (TC_History3 /= C3_Service_History) or + (TC_History3'Last(1) /= C3_Service_History'Last(1)) or + (TC_History3'First(1) /= C3_Service_History'First(1)) or + (TC_History3'Last(2) /= C3_Service_History'Last(2)) or + (TC_History3'First(2) /= C3_Service_History'First(2)) + then + Report.Failed ("Incorrect data from stream - 3"); + end if; + + -- Verify that the user defined subprograms were used to override + -- the default 'Input and 'Output attributes. + -- There were three calls on each of the user defined attributes. + + if (TC_Input_Total /= 12 ) or (TC_Output_Total /= 27 ) then + Report.Failed ("Incorrect use of user defined attributes"); + end if; + + end Verify_Data_Block; + + exception + + when others => + Report.Failed ("Exception raised in Operational Test Block"); + + end Operational_Test_Block; + + if Ada.Streams.Stream_IO.Is_Open (Util_File) then + Ada.Streams.Stream_IO.Delete (Util_File); + else + Ada.Streams.Stream_IO.Open (Util_File, + Ada.Streams.Stream_IO.Out_File, + Utility_Filename); + Ada.Streams.Stream_IO.Delete (Util_File); + end if; + + + exception + + -- Since Use_Error or Name_Error can be raised if, for the specified + -- mode, the environment does not support Stream_IO operations, + -- the following handlers are included: + + when Ada.Streams.Stream_IO.Name_Error => + Report.Not_Applicable ("Name_Error raised on Stream IO Create"); + + when Ada.Streams.Stream_IO.Use_Error => + Report.Not_Applicable ("Use_Error raised on Stream IO Create"); + + when others => + Report.Failed ("Unexpected exception raised"); + + end Test_for_Stream_IO_Support; + + Report.Result; + +end CXACB02; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxacc01.a b/gcc/testsuite/ada/acats/tests/cxa/cxacc01.a new file mode 100644 index 000000000..3ab88f40e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxacc01.a @@ -0,0 +1,299 @@ +-- CXACC01.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 use of 'Class'Output and 'Class'Input allow stream +-- manipulation of objects of non-limited class-wide types. +-- +-- TEST DESCRIPTION: +-- This test demonstrates the uses of 'Class'Output and 'Class'Input +-- in moving objects of a particular class to and from a stream file. +-- A procedure uses a class-wide parameter to move objects of specific +-- types in the class to the stream, using the 'Class'Output attribute +-- of the root type of the class. A function returns a class-wide object, +-- using the 'Class'Input attribute of the root type of the class to +-- extract the object from the stream. +-- A field-by-field comparison of record objects is performed to validate +-- the data read from the stream. Operator precedence rules are used +-- in the comparison rather than parentheses. +-- +-- APPLICABILITY CRITERIA: +-- This test is applicable to all implementations capable of supporting +-- external Stream_IO files. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 14 Nov 95 SAIC Corrected prefix of 'Tag attribute for ACVC 2.0.1. +-- 24 Aug 96 SAIC Changed a call to "Create" to "Reset". +-- 26 Feb 97 CTA.PWB Allowed for non-support of some IO operations. +--! + +with FXACC00, Ada.Streams.Stream_IO, Ada.Tags, Report; + +procedure CXACC01 is + + Order_File : Ada.Streams.Stream_IO.File_Type; + Order_Stream : Ada.Streams.Stream_IO.Stream_Access; + Order_Filename : constant String := + Report.Legal_File_Name ( Nam => "CXACC01" ); + Incomplete : exception; + +begin + + Report.Test ("CXACC01", "Check that the use of 'Class'Output " & + "and 'Class'Input allow stream manipulation " & + "of objects of non-limited class-wide types"); + + Test_for_Stream_IO_Support: + begin + + -- If an implementation does not support Stream_IO in a particular + -- environment, the exception Use_Error or Name_Error will be raised on + -- calls to various Stream_IO operations. This block statement + -- encloses a call to Create, which should produce an exception in a + -- non-supportive environment. These exceptions will be handled to + -- produce a Not_Applicable result. + + Ada.Streams.Stream_IO.Create (Order_File, + Ada.Streams.Stream_IO.Out_File, + Order_Filename); + + exception + + when Ada.Streams.Stream_IO.Use_Error | Ada.Streams.Stream_IO.Name_Error => + Report.Not_Applicable + ( "Files not supported - Create as Out_File for Stream_IO" ); + raise Incomplete; + + end Test_for_Stream_IO_Support; + + Operational_Test_Block: + declare + + -- Store tag values associated with objects of tagged types. + + TC_Box_Office_Tag : constant String := + Ada.Tags.External_Tag(FXACC00.Ticket_Request'Tag); + + TC_Summer_Tag : constant String := + Ada.Tags.External_Tag(FXACC00.Subscriber_Request'Tag); + + TC_Mayoral_Tag : constant String := + Ada.Tags.External_Tag(FXACC00.VIP_Request'Tag); + + TC_Late_Tag : constant String := + Ada.Tags.External_Tag(FXACC00.Last_Minute_Request'Tag); + + -- The following procedure will take an object of the Ticket_Request + -- class and output it to the stream. Objects of any extended type + -- in the class can be output to the stream with this procedure. + + procedure Order_Entry (Order : FXACC00.Ticket_Request'Class) is + begin + FXACC00.Ticket_Request'Class'Output (Order_Stream, Order); + end Order_Entry; + + + -- The following function will retrieve from the stream an object of + -- the Ticket_Request class. + + function Order_Retrieval return FXACC00.Ticket_Request'Class is + begin + return FXACC00.Ticket_Request'Class'Input (Order_Stream); + end Order_Retrieval; + + begin + + Order_Stream := Ada.Streams.Stream_IO.Stream (Order_File); + + -- Store the data objects in the stream. + -- Each of the objects is of a different type within the class. + + Order_Entry (FXACC00.Box_Office_Request); -- Object of root type + Order_Entry (FXACC00.Summer_Subscription); -- Obj. of extended type + Order_Entry (FXACC00.Mayoral_Ticket_Request); -- Obj. of extended type + Order_Entry (FXACC00.Late_Request); -- Object of twice + -- extended type. + + -- Reset mode of stream to In_File prior to reading data from it. + Reset1: + begin + Ada.Streams.Stream_IO.Reset (Order_File, + Ada.Streams.Stream_IO.In_File); + exception + when Ada.Streams.Stream_IO.Use_Error => + Report.Not_Applicable + ( "Reset to In_File not supported for Stream_IO - 1" ); + raise Incomplete; + end Reset1; + + Process_Order_Block: + declare + + use FXACC00; + + -- Declare variables of the root type class, + -- and initialize them with class-wide objects returned from + -- the stream as function result. + + Order_1 : Ticket_Request'Class := Order_Retrieval; + Order_2 : Ticket_Request'Class := Order_Retrieval; + Order_3 : Ticket_Request'Class := Order_Retrieval; + Order_4 : Ticket_Request'Class := Order_Retrieval; + + -- Declare objects of the specific types from within the class + -- that correspond to the types of the data written to the + -- stream. Perform a type conversion on the class-wide objects. + + Ticket_Order : Ticket_Request := + Ticket_Request(Order_1); + Subscriber_Order : Subscriber_Request := + Subscriber_Request(Order_2); + VIP_Order : VIP_Request := + VIP_Request(Order_3); + Last_Minute_Order : Last_Minute_Request := + Last_Minute_Request(Order_4); + + begin + + -- Perform a field-by-field comparison of all the class-wide + -- objects input from the stream with specific type objects + -- originally written to the stream. + + if Ticket_Order.Location /= + Box_Office_Request.Location or + Ticket_Order.Number_Of_Tickets /= + Box_Office_Request.Number_Of_Tickets + then + Report.Failed ("Ticket_Request object validation failure"); + end if; + + if Subscriber_Order.Location /= + Summer_Subscription.Location or + Subscriber_Order.Number_Of_Tickets /= + Summer_Subscription.Number_Of_Tickets or + Subscriber_Order.Subscription_Number /= + Summer_Subscription.Subscription_Number + then + Report.Failed ("Subscriber_Request object validation failure"); + end if; + + if VIP_Order.Location /= + Mayoral_Ticket_Request.Location or + VIP_Order.Number_Of_Tickets /= + Mayoral_Ticket_Request.Number_Of_Tickets or + VIP_Order.Rank /= + Mayoral_Ticket_Request.Rank + then + Report.Failed ("VIP_Request object validation failure"); + end if; + + if Last_Minute_Order.Location /= + Late_Request.Location or + Last_Minute_Order.Number_Of_Tickets /= + Late_Request.Number_Of_Tickets or + Last_Minute_Order.Rank /= + Late_Request.Rank or + Last_Minute_Order.Special_Consideration /= + Late_Request.Special_Consideration or + Last_Minute_Order.Donation /= + Late_Request.Donation + then + Report.Failed ("Last_Minute_Request object validation failure"); + end if; + + -- Verify tag values from before and after processing. + -- The 'Tag attribute is used with objects of a class-wide type. + + if TC_Box_Office_Tag /= + Ada.Tags.External_Tag(Order_1'Tag) + then + Report.Failed("Failed tag comparison - 1"); + end if; + + if TC_Summer_Tag /= + Ada.Tags.External_Tag(Order_2'Tag) + then + Report.Failed("Failed tag comparison - 2"); + end if; + + if TC_Mayoral_Tag /= + Ada.Tags.External_Tag(Order_3'Tag) + then + Report.Failed("Failed tag comparison - 3"); + end if; + + if TC_Late_Tag /= + Ada.Tags.External_Tag(Order_4'Tag) + then + Report.Failed("Failed tag comparison - 4"); + end if; + + end Process_Order_Block; + + -- After all the data has been correctly extracted, the file + -- should be empty. + + if not Ada.Streams.Stream_IO.End_Of_File (Order_File) then + Report.Failed ("Stream file not empty"); + end if; + + exception + when Incomplete => + raise; + when Constraint_Error => + Report.Failed ("Constraint_Error raised in Operational Block"); + when others => + Report.Failed ("Exception raised in Operational Test Block"); + end Operational_Test_Block; + + Deletion: + begin + if Ada.Streams.Stream_IO.Is_Open (Order_File) then + Ada.Streams.Stream_IO.Delete (Order_File); + else + Ada.Streams.Stream_IO.Open (Order_File, + Ada.Streams.Stream_IO.Out_File, + Order_Filename); + Ada.Streams.Stream_IO.Delete (Order_File); + end if; + exception + when others => + Report.Failed + ( "Delete not properly implemented for Stream_IO" ); + end Deletion; + + Report.Result; + +exception + + when Incomplete => + Report.Result; + when others => + Report.Failed ( "Unexpected exception" ); + Report.Result; + +end CXACC01; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaf001.a b/gcc/testsuite/ada/acats/tests/cxa/cxaf001.a new file mode 100644 index 000000000..ae3497abd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxaf001.a @@ -0,0 +1,199 @@ +-- CXAF001.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 an implementation supports the functionality defined +-- in Package Ada.Command_Line. +-- +-- TEST DESCRIPTION: +-- This test verifies that an implementation supports the subprograms +-- contained in package Ada.Command_Line. Each of the subprograms +-- is exercised in a general sense, to ensure that it is available, +-- and that it provides the prescribed results in a known test +-- environment. Function Argument_Count must return zero, or the +-- number of arguments passed to the program calling it. Function +-- Argument is called with a parameter value one greater than the +-- actual number of arguments passed to the executing program, which +-- must result in Constraint_Error being raised. Function Command_Name +-- should return the name of the executing program that called it +-- (specifically, this test name). Function Set_Exit_Status is called +-- with two different parameter values, the constants Failure and +-- Success defined in package Ada.Command_Line. +-- +-- The setting of the variable TC_Verbose allows for some additional +-- output to be displayed during the running of the test as an aid in +-- tracing the processing flow of the test. +-- +-- APPLICABILITY CRITERIA: +-- This test is applicable to implementations that support the +-- declaration of package Command_Line as defined in the Ada Reference +-- manual. +-- An alternative declaration is allowed for package Command_Line if +-- different functionality is appropriate for the external execution +-- environment. +-- +-- +-- CHANGE HISTORY: +-- 10 Jul 95 SAIC Initial prerelease version. +-- 02 May 96 SAIC Incorporated reviewer comments for ACVC 2.1. +-- 05 AUG 98 EDS Allow Null string result to be returned from +-- Function Command +--! + +with Ada.Command_Line; +with Ada.Exceptions; +with Report; + +procedure CXAF001 is +begin + + Report.Test ("CXAF001", "Check that an implementation supports the " & + "functionality defined in Package " & + "Ada.Command_Line"); + + Test_Block: + declare + + use Ada.Exceptions; + + type String_Access is access all String; + + TC_Verbose : Boolean := False; + Number_Of_Arguments : Natural := Natural'Last; + Name_Of_Command : String_Access; + + begin + + -- Check the result of function Argument_Count. + -- Note: If the external environment does not support passing arguments + -- to the program invoking the function, the function result + -- will be zero. + + Number_Of_Arguments := Ada.Command_Line.Argument_Count; + if Number_Of_Arguments = Natural'Last then + Report.Failed("Argument_Count did not provide a return result"); + end if; + if TC_Verbose then + Report.Comment + ("Argument_Count = " & Integer'Image(Number_Of_Arguments)); + end if; + + + -- Check that the result of Function Argument is Constraint_Error + -- when the Number argument is outside the range of 1..Argument_Count. + + Test_Function_Argument_1 : + begin + declare + + -- Define a value that will be outside the range of + -- 1..Argument_Count. + -- Note: If the external execution environment does not support + -- passing arguments to a program, then Argument(N) for + -- any N will raise Constraint_Error, since + -- Argument_Count = 0; + + Arguments_Plus_One : Positive := + Ada.Command_Line.Argument_Count + 1; + + -- Using the above value in a call to Argument must result in + -- the raising of Constraint_Error. + + Argument_String : constant String := + Ada.Command_Line.Argument(Arguments_Plus_One); + + begin + Report.Failed("Constraint_Error not raised by Function " & + "Argument when provided a Number argument " & + "out of range"); + end; + exception + when Constraint_Error => null; -- OK, expected exception. + if TC_Verbose then + Report.Comment ("Argument_Count raised Constraint_Error"); + end if; + when others => + Report.Failed ("Unexpected exception raised by Argument " & + "in Test_Function_Argument_1 block"); + end Test_Function_Argument_1; + + + -- Check that Function Argument returns a string result. + + Test_Function_Argument_2 : + begin + if Ada.Command_Line.Argument_Count > 0 then + Report.Comment + ("Last argument is: " & + Ada.Command_Line.Argument(Ada.Command_Line.Argument_Count)); + elsif TC_Verbose then + Report.Comment("Argument_Count is zero, no test of Function " & + "Argument for string result"); + end if; + exception + when others => + Report.Failed ("Unexpected exception raised by Argument " & + "in Test_Function_Argument_2 block"); + end Test_Function_Argument_2; + + + -- Check the result of Function Command_Name. + + Name_Of_Command := new String'(Ada.Command_Line.Command_Name); + + if Name_Of_Command = null then + Report.Failed("Null string pointer returned from Function Command"); + elsif Name_Of_Command.all = "" then + Report.Comment("Null string result returned from Function Command"); + elsif TC_Verbose then + Report.Comment("Invoking command is " & Name_Of_Command.all); + end if; + + + -- Check that procedure Set_Exit_Status is available. + -- Note: If the external execution environment does not support + -- returning an exit value from a program, then Set_Exit_Status + -- does nothing. + + Ada.Command_Line.Set_Exit_Status(Ada.Command_Line.Failure); + if TC_Verbose then + Report.Comment("Exit status set to Failure"); + end if; + + Ada.Command_Line.Set_Exit_Status(Ada.Command_Line.Success); + if TC_Verbose then + Report.Comment("Exit status set to Success"); + 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 CXAF001; |