Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/ada/acats/support/fdd2a00.a @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children
comparison
equal deleted inserted replaced
68:561a7518be6b 111:04ced10e8804
1 -- FDD2A00.A
2 --
3 -- Grant of Unlimited Rights
4 --
5 -- The Ada Conformity Assessment Authority (ACAA) holds unlimited
6 -- rights in the software and documentation contained herein. Unlimited
7 -- rights are the same as those granted by the U.S. Government for older
8 -- parts of the Ada Conformity Assessment Test Suite, and are defined
9 -- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
10 -- intends to confer upon all recipients unlimited rights equal to those
11 -- held by the ACAA. These rights include rights to use, duplicate,
12 -- release or disclose the released technical data and computer software
13 -- in whole or in part, in any manner and for any purpose whatsoever, and
14 -- to have or permit others to do so.
15 --
16 -- DISCLAIMER
17 --
18 -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
19 -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
20 -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
21 -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
22 -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
23 -- PARTICULAR PURPOSE OF SAID MATERIAL.
24 --
25 --
26 -- FOUNDATION DESCRIPTION:
27 -- This foundation provides the basis for testing user-defined stream
28 -- attributes. It provides operations which count calls to stream
29 -- attributes.
30 --
31 -- CHANGE HISTORY:
32 -- 30 JUL 2001 PHL Initial version.
33 -- 5 DEC 2001 RLB Reformatted for ACATS.
34 --
35
36 with Ada.Streams;
37 use Ada.Streams;
38 package FDD2A00 is
39
40 type Kinds is (Read, Write, Input, Output);
41 type Counts is array (Kinds) of Natural;
42
43
44 type My_Stream (Size : Stream_Element_Count) is new Root_Stream_Type with
45 record
46 First : Stream_Element_Offset := 1;
47 Last : Stream_Element_Offset := 0;
48 Contents : Stream_Element_Array (1 .. Size);
49 end record;
50
51 procedure Clear (Stream : in out My_Stream);
52
53 procedure Read (Stream : in out My_Stream;
54 Item : out Stream_Element_Array;
55 Last : out Stream_Element_Offset);
56
57 procedure Write (Stream : in out My_Stream; Item : in Stream_Element_Array);
58
59
60 generic
61 type T (<>) is limited private;
62 with procedure Actual_Write
63 (Stream : access Root_Stream_Type'Class; Item : T);
64 with function Actual_Input
65 (Stream : access Root_Stream_Type'Class) return T;
66 with procedure Actual_Read (Stream : access Root_Stream_Type'Class;
67 Item : out T);
68 with procedure Actual_Output
69 (Stream : access Root_Stream_Type'Class; Item : T);
70 package Counting_Stream_Ops is
71
72 procedure Write (Stream : access Root_Stream_Type'Class; Item : T);
73 function Input (Stream : access Root_Stream_Type'Class) return T;
74 procedure Read (Stream : access Root_Stream_Type'Class; Item : out T);
75 procedure Output (Stream : access Root_Stream_Type'Class; Item : T);
76
77 function Get_Counts return Counts;
78
79 end Counting_Stream_Ops;
80
81 end FDD2A00;
82 package body FDD2A00 is
83
84 procedure Clear (Stream : in out My_Stream) is
85 begin
86 Stream.First := 1;
87 Stream.Last := 0;
88 end Clear;
89
90 procedure Read (Stream : in out My_Stream;
91 Item : out Stream_Element_Array;
92 Last : out Stream_Element_Offset) is
93 begin
94 if Item'Length >= Stream.Last - Stream.First + 1 then
95 Item (Item'First .. Item'First + Stream.Last - Stream.First) :=
96 Stream.Contents (Stream.First .. Stream.Last);
97 Last := Item'First + Stream.Last - Stream.First;
98 Stream.First := Stream.Last + 1;
99 else
100 Item := Stream.Contents (Stream.First ..
101 Stream.First + Item'Length - 1);
102 Last := Item'Last;
103 Stream.First := Stream.First + Item'Length;
104 end if;
105 end Read;
106
107 procedure Write (Stream : in out My_Stream;
108 Item : in Stream_Element_Array) is
109 begin
110 Stream.Contents (Stream.Last + 1 .. Stream.Last + Item'Length) := Item;
111 Stream.Last := Stream.Last + Item'Length;
112 end Write;
113
114
115 package body Counting_Stream_Ops is
116 Cnts : Counts := (others => 0);
117
118 procedure Write (Stream : access Root_Stream_Type'Class; Item : T) is
119 begin
120 Cnts (Write) := Cnts (Write) + 1;
121 Actual_Write (Stream, Item);
122 end Write;
123
124 function Input (Stream : access Root_Stream_Type'Class) return T is
125 begin
126 Cnts (Input) := Cnts (Input) + 1;
127 return Actual_Input (Stream);
128 end Input;
129
130 procedure Read (Stream : access Root_Stream_Type'Class; Item : out T) is
131 begin
132 Cnts (Read) := Cnts (Read) + 1;
133 Actual_Read (Stream, Item);
134 end Read;
135
136 procedure Output (Stream : access Root_Stream_Type'Class; Item : T) is
137 begin
138 Cnts (Output) := Cnts (Output) + 1;
139 Actual_Output (Stream, Item);
140 end Output;
141
142 function Get_Counts return Counts is
143 begin
144 return Cnts;
145 end Get_Counts;
146
147 end Counting_Stream_Ops;
148
149 end FDD2A00;