URL
https://opencores.org/ocsvn/openrisc_2011-10-31/openrisc_2011-10-31/trunk
Subversion Repositories openrisc_2011-10-31
[/] [openrisc/] [tags/] [gnu-src/] [gcc-4.5.1/] [gcc-4.5.1-or32-1.0rc2/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [cd/] [cdd2001.a] - Rev 384
Compare with Previous | Blame | View Log
-- 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;