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/cd/cdd2001.a | 203 +++++++++++++++++++++++++++++ 1 file changed, 203 insertions(+) create mode 100644 gcc/testsuite/ada/acats/tests/cd/cdd2001.a (limited to 'gcc/testsuite/ada/acats/tests/cd/cdd2001.a') diff --git a/gcc/testsuite/ada/acats/tests/cd/cdd2001.a b/gcc/testsuite/ada/acats/tests/cd/cdd2001.a new file mode 100644 index 000000000..3184dded8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cdd2001.a @@ -0,0 +1,203 @@ +-- CDD2001.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 the default implementation of Read and Input raise End_Error +-- if the end of stream is reached before the reading of a value is +-- completed. (Defect Report 8652/0045, +-- Technical Corrigendum 13.13.2(35.1/1)). +-- +-- CHANGE HISTORY: +-- 12 FEB 2001 PHL Initial version. +-- 29 JUN 2001 RLB Reformatted for ACATS. +-- +--! + +with Ada.Streams; +use Ada.Streams; +package CDD2001_0 is + + type My_Stream (Size : Stream_Element_Count) is new Root_Stream_Type with + record + First : Stream_Element_Offset := 1; + Last : Stream_Element_Offset := 0; + Contents : Stream_Element_Array (1 .. Size); + end record; + + procedure Clear (Stream : in out My_Stream); + + procedure Read (Stream : in out My_Stream; + Item : out Stream_Element_Array; + Last : out Stream_Element_Offset); + + procedure Write (Stream : in out My_Stream; Item : in Stream_Element_Array); + +end CDD2001_0; + +package body CDD2001_0 is + + procedure Clear (Stream : in out My_Stream) is + begin + Stream.First := 1; + Stream.Last := 0; + end Clear; + + procedure Read (Stream : in out My_Stream; + Item : out Stream_Element_Array; + Last : out Stream_Element_Offset) is + begin + if Item'Length >= Stream.Last - Stream.First + 1 then + Item (Item'First .. Item'First + Stream.Last - Stream.First) := + Stream.Contents (Stream.First .. Stream.Last); + Last := Item'First + Stream.Last - Stream.First; + Stream.First := Stream.Last + 1; + else + Item := Stream.Contents (Stream.First .. + Stream.First + Item'Length - 1); + Last := Item'Last; + Stream.First := Stream.First + Item'Length; + end if; + end Read; + + procedure Write (Stream : in out My_Stream; + Item : in Stream_Element_Array) is + begin + Stream.Contents (Stream.Last + 1 .. Stream.Last + Item'Length) := Item; + Stream.Last := Stream.Last + Item'Length; + end Write; + +end CDD2001_0; + +with Ada.Exceptions; +use Ada.Exceptions; +with CDD2001_0; +use CDD2001_0; +with Io_Exceptions; +use Io_Exceptions; +with Report; +use Report; +procedure CDD2001 is + + subtype Int is Integer range -20 .. 20; + + type R (D : Int) is + record + C1 : Character := Ident_Char ('a'); + case D is + when 0 .. 20 => + C2 : String (1 .. D) := (others => Ident_Char ('b')); + when others => + C3, C4 : Float := Float (-D); + end case; + end record; + + S : aliased My_Stream (200); + +begin + Test + ("CDD2001", + "Check that the default implementation of Read and Input " & + "raise End_Error if the end of stream is reached before the " & + "reading of a value is completed"); + + Read: + declare + X : R (Ident_Int (13)); + begin + Clear (S); + + -- A complete object. + R'Write (S'Access, X); + X.C1 := Ident_Char ('A'); + X.C2 := (others => Ident_Char ('B')); + R'Read (S'Access, X); + if X.C1 /= Ident_Char ('a') or X.C2 /= + (1 .. 13 => Ident_Char ('b')) then + Failed ("Read did not produce the expected result"); + end if; + + Clear (S); + + -- Not enough data. + Character'Write (S'Access, 'a'); + String'Write (S'Access, "bbb"); + + begin + R'Read (S'Access, X); + Failed + ("No exception raised when the end of stream is reached " & + "before the reading of a value is completed - 1"); + exception + when End_Error => + null; + when E: others => + Failed ("Wrong Exception " & Exception_Name (E) & + " - " & Exception_Information (E) & + " - " & Exception_Message (E) & " - 1"); + end; + + end Read; + + Input: + declare + X : R (Ident_Int (-11)); + begin + Clear (S); + + -- A complete object. + R'Output (S'Access, X); + X.C1 := Ident_Char ('A'); + X.C3 := 4.0; + X.C4 := 5.0; + X := R'Input (S'Access); + if X.C1 /= Ident_Char ('a') or X.C3 /= 11.0 or X.C4 /= 11.0 then + Failed ("Input did not produce the expected result"); + end if; + + Clear (S); + + -- Not enough data. + Integer'Output (S'Access, Ident_Int (-11)); -- The discriminant + Character'Output (S'Access, 'a'); + Float'Output (S'Access, 11.0); + + begin + X := R'Input (S'Access); + Failed + ("No exception raised when the end of stream is reached " & + "before the reading of a value is completed - 2"); + exception + when End_Error => + null; + when E: others => + Failed ("Wrong exception " & Exception_Name (E) & + " - " & Exception_Message (E) & " - 2"); + end; + + end Input; + + Result; +end CDD2001; + -- cgit v1.2.3