llvm-gcc-4.2/gcc/testsuite/ada/acats/tests/cd/cdd2001.a

-- 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;