From 554fd8c5195424bdbcabf5de30fdc183aba391bd Mon Sep 17 00:00:00 2001 From: upstream source tree Date: Sun, 15 Mar 2015 20:14:05 -0400 Subject: obtained gcc-4.6.4.tar.bz2 from upstream website; 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. --- gcc/testsuite/ada/acats/tests/cxa/cxa4005.a | 683 ++++++++++++++++++++++++++++ 1 file changed, 683 insertions(+) create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxa4005.a (limited to 'gcc/testsuite/ada/acats/tests/cxa/cxa4005.a') 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; -- cgit v1.2.3