Mercurial > hg > CbC > CbC_gcc
diff gcc/testsuite/ada/acats/support/fdd2a00.a @ 111:04ced10e8804
gcc 7
author | kono |
---|---|
date | Fri, 27 Oct 2017 22:46:09 +0900 |
parents | |
children |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/gcc/testsuite/ada/acats/support/fdd2a00.a Fri Oct 27 22:46:09 2017 +0900 @@ -0,0 +1,149 @@ +-- FDD2A00.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. +-- +-- +-- FOUNDATION DESCRIPTION: +-- This foundation provides the basis for testing user-defined stream +-- attributes. It provides operations which count calls to stream +-- attributes. +-- +-- CHANGE HISTORY: +-- 30 JUL 2001 PHL Initial version. +-- 5 DEC 2001 RLB Reformatted for ACATS. +-- + +with Ada.Streams; +use Ada.Streams; +package FDD2A00 is + + type Kinds is (Read, Write, Input, Output); + type Counts is array (Kinds) of Natural; + + + 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); + + + generic + type T (<>) is limited private; + with procedure Actual_Write + (Stream : access Root_Stream_Type'Class; Item : T); + with function Actual_Input + (Stream : access Root_Stream_Type'Class) return T; + with procedure Actual_Read (Stream : access Root_Stream_Type'Class; + Item : out T); + with procedure Actual_Output + (Stream : access Root_Stream_Type'Class; Item : T); + package Counting_Stream_Ops is + + procedure Write (Stream : access Root_Stream_Type'Class; Item : T); + function Input (Stream : access Root_Stream_Type'Class) return T; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out T); + procedure Output (Stream : access Root_Stream_Type'Class; Item : T); + + function Get_Counts return Counts; + + end Counting_Stream_Ops; + +end FDD2A00; +package body FDD2A00 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; + + + package body Counting_Stream_Ops is + Cnts : Counts := (others => 0); + + procedure Write (Stream : access Root_Stream_Type'Class; Item : T) is + begin + Cnts (Write) := Cnts (Write) + 1; + Actual_Write (Stream, Item); + end Write; + + function Input (Stream : access Root_Stream_Type'Class) return T is + begin + Cnts (Input) := Cnts (Input) + 1; + return Actual_Input (Stream); + end Input; + + procedure Read (Stream : access Root_Stream_Type'Class; Item : out T) is + begin + Cnts (Read) := Cnts (Read) + 1; + Actual_Read (Stream, Item); + end Read; + + procedure Output (Stream : access Root_Stream_Type'Class; Item : T) is + begin + Cnts (Output) := Cnts (Output) + 1; + Actual_Output (Stream, Item); + end Output; + + function Get_Counts return Counts is + begin + return Cnts; + end Get_Counts; + + end Counting_Stream_Ops; + +end FDD2A00;