aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.9/gcc/testsuite/ada/acats/tests/cd/cdd2001.a
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.9/gcc/testsuite/ada/acats/tests/cd/cdd2001.a')
-rw-r--r--gcc-4.9/gcc/testsuite/ada/acats/tests/cd/cdd2001.a203
1 files changed, 203 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/cd/cdd2001.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/cd/cdd2001.a
new file mode 100644
index 000000000..3184dded8
--- /dev/null
+++ b/gcc-4.9/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;
+