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/cxb/cxb3014.a | 254 ++++++++++++++++++++++++++++ 1 file changed, 254 insertions(+) create mode 100644 gcc/testsuite/ada/acats/tests/cxb/cxb3014.a (limited to 'gcc/testsuite/ada/acats/tests/cxb/cxb3014.a') diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb3014.a b/gcc/testsuite/ada/acats/tests/cxb/cxb3014.a new file mode 100644 index 000000000..a9b386ffc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb3014.a @@ -0,0 +1,254 @@ +-- CXB3014.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that the Function Value with Pointer and Element +-- parameters will return an Element_Array result of correct size +-- and content (up to and including the first "terminator" Element). +-- +-- Check that the Function Value with Pointer and Length parameters +-- will return an Element_Array result of appropriate size and content +-- (the first Length elements pointed to by the parameter Ref). +-- +-- Check that both versions of Function Value will propagate +-- Interfaces.C.Strings.Dereference_Error when the value of +-- the Ref pointer parameter is null. +-- +-- TEST DESCRIPTION: +-- This test tests that both versions of Function Value from the +-- generic package Interfaces.C.Pointers are available and produce +-- correct results. The generic package is instantiated with size_t, +-- char, char_array, and nul as actual parameters, and subtests are +-- performed on each of the Value functions resulting from this +-- instantiation. +-- For both function versions, a test is performed where a portion of +-- a char_array is to be returned as the function result. Likewise, +-- a test is performed where each version of the function returns the +-- entire char_array referenced by the in parameter Ref. +-- Finally, both versions of Function Value are called with a null +-- pointer reference, to ensure that Dereference_Error is raised in +-- this case. +-- +-- This test assumes that the following characters are all included +-- in the implementation defined type Interfaces.C.char: +-- ' ', 'a'..'z', and 'A'..'Z'. +-- +-- APPLICABILITY CRITERIA: +-- This test is applicable to all implementations that provide +-- packages Interfaces.C.Strings and Interfaces.C.Pointers. If an +-- implementation provides packages Interfaces.C.Strings and +-- Interfaces.C.Pointers, this test must compile, execute, and +-- report "PASSED". +-- +-- +-- CHANGE HISTORY: +-- 19 Oct 95 SAIC Initial prerelease version. +-- 13 May 96 SAIC Incorporated reviewer comments for ACVC 2.1. +-- 23 Oct 96 SAIC Incorporated reviewer comments. +-- +--! + +with Report; +with Interfaces.C.Strings; -- N/A => ERROR +with Interfaces.C.Pointers; -- N/A => ERROR + +procedure CXB3014 is + +begin + + Report.Test ("CXB3014", "Check that versions of the Value function " & + "from package Interfaces.C.Pointers produce " & + "correct results"); + + Test_Block: + declare + + use type Interfaces.C.char, Interfaces.C.size_t; + + Char_a : constant Interfaces.C.char := 'a'; + Char_j : constant Interfaces.C.char := 'j'; + Char_z : constant Interfaces.C.char := 'z'; + + subtype Lower_Case_chars is Interfaces.C.char range Char_a..Char_z; + subtype Char_Range is Interfaces.C.size_t range 0..26; + + Local_nul : aliased Interfaces.C.char := Interfaces.C.nul; + TC_Array_Size : Interfaces.C.size_t := 20; + + TC_String_1 : constant String := "abcdefghij"; + TC_String_2 : constant String := "abcdefghijklmnopqrstuvwxyz"; + TC_String_3 : constant String := "abcdefghijklmnopqrst"; + TC_String_4 : constant String := "abcdefghijklmnopqrstuvwxyz"; + TC_Blank_String : constant String := " "; + + TC_Char_Array : Interfaces.C.char_array(Char_Range) := + Interfaces.C.To_C(TC_String_2, True); + + TC_Char_Array_1 : Interfaces.C.char_array(0..9); + TC_Char_Array_2 : Interfaces.C.char_array(Char_Range); + TC_Char_Array_3 : Interfaces.C.char_array(0..TC_Array_Size-1); + TC_Char_Array_4 : Interfaces.C.char_array(Char_Range); + + package Char_Pointers is new + Interfaces.C.Pointers (Index => Interfaces.C.size_t, + Element => Interfaces.C.char, + Element_Array => Interfaces.C.char_array, + Default_Terminator => Interfaces.C.nul); + + Char_Ptr : Char_Pointers.Pointer; + + use type Char_Pointers.Pointer; + + begin + + -- Check that the Function Value with Pointer and Terminator Element + -- parameters will return an Element_Array result of appropriate size + -- and content (up to and including the first "terminator" Element.) + + Char_Ptr := TC_Char_Array(0)'Access; + + -- Provide a new Terminator char in the call of Function Value. + -- This call should return only a portion (the first 10 chars) of + -- the referenced char_array, up to and including the char 'j'. + + TC_Char_Array_1 := Char_Pointers.Value(Ref => Char_Ptr, + Terminator => Char_j); + + if Interfaces.C.To_Ada(TC_Char_Array_1, False) /= TC_String_1 or + Interfaces.C.Is_Nul_Terminated(TC_Char_Array_1) + then + Report.Failed("Incorrect result from Function Value with Ref " & + "and Terminator parameters, when supplied with " & + "a non-default Terminator char"); + end if; + + -- Use the default Terminator char in the call of Function Value. + -- This call should return the entire char_array, including the + -- terminating nul char. + + TC_Char_Array_2 := Char_Pointers.Value(Char_Ptr); + + if Interfaces.C.To_Ada(TC_Char_Array_2, True) /= TC_String_2 or + not Interfaces.C.Is_Nul_Terminated(TC_Char_Array_2) + then + Report.Failed("Incorrect result from Function Value with Ref " & + "and Terminator parameters, when using the " & + "default Terminator char"); + end if; + + + + -- Check that the Function Value with Pointer and Length parameters + -- will return an Element_Array result of appropriate size and content + -- (the first Length elements pointed to by the parameter Ref). + + -- This call should return only a portion (the first 20 chars) of + -- the referenced char_array. + + TC_Char_Array_3 := + Char_Pointers.Value(Ref => Char_Ptr, + Length => Interfaces.C.ptrdiff_t(TC_Array_Size)); + + -- Verify the individual chars of the result. + for i in 0..TC_Array_Size-1 loop + if Interfaces.C.To_Ada(TC_Char_Array_3(i)) /= + TC_String_3(Integer(i)+1) + then + Report.Failed("Incorrect result from Function Value with " & + "Ref and Length parameters, when specifying " & + "a length less than the full array size"); + exit; + end if; + end loop; + + -- This call should return the entire char_array, including the + -- terminating nul char. + + TC_Char_Array_4 := Char_Pointers.Value(Char_Ptr, 27); + + if Interfaces.C.To_Ada(TC_Char_Array_4, True) /= TC_String_4 or + not Interfaces.C.Is_Nul_Terminated(TC_Char_Array_4) + then + Report.Failed("Incorrect result from Function Value with Ref " & + "and Length parameters, when specifying the " & + "entire array size"); + end if; + + + + -- Check that both of the above versions of Function Value will + -- propagate Interfaces.C.Strings.Dereference_Error when the value of + -- the Ref Pointer parameter is null. + + Char_Ptr := null; + + begin + TC_Char_Array_1 := Char_Pointers.Value(Ref => Char_Ptr, + Terminator => Char_j); + Report.Failed("Dereference_Error not raised by Function " & + "Value with Terminator parameter, when " & + "provided a null reference"); + -- Call Report.Comment to ensure that the assignment to + -- TC_Char_Array_1 is not "dead", and therefore can not be + -- optimized away. + Report.Comment(Interfaces.C.To_Ada(TC_Char_Array_1, False)); + exception + when Interfaces.C.Strings.Dereference_Error => + null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by Function " & + "Value with Terminator parameter, when " & + "provided a null reference"); + end; + + + begin + TC_Char_Array_3 := + Char_Pointers.Value(Char_Ptr, + Interfaces.C.ptrdiff_t(TC_Array_Size)); + Report.Failed("Dereference_Error not raised by Function " & + "Value with Length parameter, when provided " & + "a null reference"); + -- Call Report.Comment to ensure that the assignment to + -- TC_Char_Array_3 is not "dead", and therefore can not be + -- optimized away. + Report.Comment(Interfaces.C.To_Ada(TC_Char_Array_3, False)); + exception + when Interfaces.C.Strings.Dereference_Error => + null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by Function " & + "Value with Length parameter, when " & + "provided a null reference"); + end; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + +end CXB3014; -- cgit v1.2.3